Squeak-dev March 2015

squeak-dev@lists.squeakfoundation.org

40 participants
315 discussions

The Trunk: ToolBuilder-Morphic-mt.96.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Marcel Taeumel uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-mt.96.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-mt.96 Author: mt Time: 7 March 2015, 12:24:54.258 pm UUID: 1fd5e40f-e940-cd43-a5b2-29f67a38e5e4 Ancestors: ToolBuilder-Morphic-mt.95 Fixes current selection where model objects looked the same but where not identical. =============== Diff against ToolBuilder-Morphic-mt.95 =============== Item was changed: ----- Method: PluggableTreeMorph>>getCurrentSelectionItem (in category 'selection') ----- getCurrentSelectionItem "Our models are supposed to return real objects, not wrappers. See PluggableTreeItemNode." | selectedObject | selectedObject := self getSelectedSelector ifNil: [^ nil] ifNotNil: [:symbol | model perform: symbol]. ^ scroller submorphs + detect: [:each | each complexContents item == selectedObject] - detect: [:each | each complexContents item = selectedObject] ifFound: [:each | each complexContents] ifNone: [nil]!

1 0

The Trunk: Tools-mt.543.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Marcel Taeumel uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-mt.543.mcz ==================== Summary ==================== Name: Tools-mt.543 Author: mt Time: 7 March 2015, 12:19:49.606 pm UUID: 7bef3495-7dcd-0346-99d7-7c335ced4c3a Ancestors: Tools-mt.542 Browser icons fixed. =============== Diff against Tools-mt.542 =============== Item was changed: ----- Method: ToolIcons class>>iconForClass:selector: (in category 'support') ----- iconForClass: aClassDescription selector: aSelector "Answer an icon to be shown for the selector aSymbol in aClassDescription." | classDescription | classDescription := (aClassDescription isKindOf: PseudoClass) ifTrue: [aClassDescription realClass ifNil: [^ #blank ]] ifFalse: [aClassDescription]. classDescription methodDictionary at: aSelector ifPresent: [ :method | method literalsDo: [ :literal | (literal == #halt or: [ literal == #halt: or: [ literal == #haltIfNil or: [ literal == #haltIf: or: [ literal == #haltOnce or: [ literal == #haltOnce: or: [ literal == #haltOnCount: or: [ literal == #halt:onCount: ] ] ] ] ] ] ]) ifTrue: [^ #breakpoint]. (literal == #flag: or: [ literal == #needsWork or: [ literal == #notYetImplemented ] ]) ifTrue: [^ #flag]. (literal == #shouldBeImplemented or: [literal == #subclassResponsibility]) ifTrue: [^ #abstract] ] ]. ^ (classDescription isSelectorOverride: aSelector) ifTrue: [ (classDescription isSelectorOverridden: aSelector) + ifTrue: [ #arrowUpAndDown ] + ifFalse: [ #arrowUp ] ] - ifTrue: [ #arrowUp ] - ifFalse: [ #arrowUpAndDown ] ] ifFalse: [ (classDescription isSelectorOverridden: aSelector) ifTrue: [ #arrowDown ] ifFalse: [#blank ] ]!

1 0

The Trunk: Tools-mt.542.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Marcel Taeumel uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-mt.542.mcz ==================== Summary ==================== Name: Tools-mt.542 Author: mt Time: 7 March 2015, 12:19:04.957 pm UUID: 2474c709-2040-f040-99eb-6144e9acd707 Ancestors: Tools-mt.541 Object explorer now uses tool builder. Includes code clean-up and some fixes. Monitoring entries works again. =============== Diff against Tools-mt.541 =============== Item was added: + ----- Method: IndentingListItemMorph>>refresh (in category 'initialization') ----- + refresh + + self contents: complexContents asString. + icon := complexContents icon.! Item was changed: AbstractHierarchicalList subclass: #ObjectExplorer + instanceVariableNames: 'root currentParent inspector monitorList' - instanceVariableNames: 'rootObject inspector monitorList' classVariableNames: '' poolDictionaries: '' category: 'Tools-Explorer'! !ObjectExplorer commentStamp: '<historical>' prior: 0! ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like: World explore and enjoy.! Item was added: + ----- Method: ObjectExplorer class>>nodeClass (in category 'as yet unclassified') ----- + nodeClass + + ^ ObjectExplorerWrapper! Item was added: + ----- Method: ObjectExplorer>>buildWith: (in category 'toolbuilder') ----- + buildWith: builder + + | windowSpec treeSpec textSpec | + windowSpec := builder pluggableWindowSpec new. + windowSpec + model: self; + children: OrderedCollection new; + label: #label. + + treeSpec := builder pluggableTreeSpec new. + treeSpec + model: self; + nodeClass: self class nodeClass; + roots: #getList; + keyPress: #explorerKey:from:; + getSelected: #currentSelection; + setSelected: #currentSelection:; + setSelectedParent: #currentParent:; + menu: #genericMenu:; + autoDeselect: false; + columns: (ObjectExplorerWrapper showContentsInColumns + ifTrue: [{ + [:listMorph | (listMorph scroller submorphs collect: [:item | + item preferredWidthOfColumn: 1]) max]. + nil "take all the space"}] + ifFalse: []); + frame: (0@0 corner: 1(a)0.85). + windowSpec children add: treeSpec. + + textSpec := builder pluggableTextSpec new. + textSpec + model: self; + menu: #codePaneMenu:shifted:; + frame: (0(a)0.85 corner: 1@1). + windowSpec children add: textSpec. + + ^ builder build: windowSpec! Item was changed: + ----- Method: ObjectExplorer>>chasePointers (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>chasePointers (in category 'menus') ----- chasePointers "Open a PointerFinder on the selected item" | path sel savedRoot saved | path := OrderedCollection new. sel := currentSelection. [ sel isNil ] whileFalse: [ path addFirst: sel asString. sel := sel parent ]. path addFirst: #openPath. path := path asArray. savedRoot := rootObject. saved := self object. [ rootObject := nil. self changed: #getList. (Smalltalk includesKey: #PointerFinder) ifTrue: [PointerFinder on: saved] ifFalse: [self objectReferencesToSelection ]] ensure: [ rootObject := savedRoot. self changed: #getList. self changed: path. ]! Item was removed: - ----- Method: ObjectExplorer>>contentsSelection (in category 'accessing') ----- - contentsSelection - "Return the interval of text in the code pane to select when I set the pane's contents" - - ^ 1 to: 0 "null selection"! Item was added: + ----- Method: ObjectExplorer>>currentParent (in category 'accessing') ----- + currentParent + ^ currentParent! Item was added: + ----- Method: ObjectExplorer>>currentParent: (in category 'accessing') ----- + currentParent: anObject + currentParent := anObject.! Item was added: + ----- Method: ObjectExplorer>>currentSelection (in category 'accessing') ----- + currentSelection + + ^ currentSelection! Item was added: + ----- Method: ObjectExplorer>>currentSelection: (in category 'accessing') ----- + currentSelection: anObject + + self currentSelection == anObject ifTrue: [^ self]. + currentSelection := anObject. + self changed: #currentSelection.! Item was changed: + ----- Method: ObjectExplorer>>defsOfSelection (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>defsOfSelection (in category 'menus') ----- defsOfSelection "Open a browser on all defining references to the selected instance variable, if that's what's currently selected." | aClass sel | (aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash]. sel := self selector. self systemNavigation browseAllStoresInto: sel from: aClass! Item was changed: ----- Method: ObjectExplorer>>doItReceiver (in category 'accessing') ----- doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." + ^ self object! - currentSelection ifNil: [^rootObject]. - ^currentSelection withoutListWrapper - ! Item was changed: + ----- Method: ObjectExplorer>>explorePointers (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>explorePointers (in category 'menus') ----- explorePointers "Open a PointerExplorer on the current selection" PointerExplorer new openExplorerFor: self object! Item was changed: + ----- Method: ObjectExplorer>>exploreSelection (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>exploreSelection (in category 'menus') ----- exploreSelection "Open an ObjectExplorer on the current selection" self object explore! Item was removed: - ----- Method: ObjectExplorer>>explorerFor: (in category 'user interface') ----- - explorerFor: anObject - | window view | - rootObject := anObject. - window := (SystemWindow labelled: self label) model: self. - window addMorph: (view := (SimpleHierarchicalListMorph - on: self - list: #getList - selected: #getCurrentSelection - changeSelected: #noteNewSelection: - menu: #genericMenu: - keystroke: #explorerKey:from:) - columns: (ObjectExplorerWrapper showContentsInColumns - ifTrue: [{ - [:listMorph | (listMorph scroller submorphs collect: [:item | - item preferredWidthOfColumn: 1]) max]. - nil "take all the space"}] - ifFalse: []); - yourself) - frame: (0@0 corner: 1(a)0.8). - window addMorph: ((PluggableTextMorph on: self text: #trash accept: #trash: - readSelection: #contentsSelection menu: #codePaneMenu:shifted:) - askBeforeDiscardingEdits: false) - frame: (0(a)0.8 corner: 1@1). - view - autoDeselect: false. - ^ window! Item was removed: - ----- Method: ObjectExplorer>>explorerFor:withLabel: (in category 'user interface') ----- - explorerFor: anObject withLabel: label - | window view | - rootObject := anObject. - window := (SystemWindow labelled: label) - model: self. - - window - addMorph: (view := (SimpleHierarchicalListMorph - on: self - list: #getList - selected: #getCurrentSelection - changeSelected: #noteNewSelection: - menu: #genericMenu: - keystroke: nil) - columns: (ObjectExplorerWrapper showContentsInColumns - ifTrue: [{ - [:listMorph | (listMorph scroller submorphs collect: [:item | - item preferredWidthOfColumn: 1]) max]. - nil "take all the space"}] - ifFalse: []); - yourself) - frame: (0 @ 0 corner: 1 @ 0.8). - window - addMorph: ((PluggableTextMorph - on: self - text: #trash - accept: #trash: - readSelection: #contentsSelection - menu: #codePaneMenu:shifted:) - askBeforeDiscardingEdits: false) - frame: (0 @ 0.8 corner: 1 @ 1). - view autoDeselect: false. - ^ window! Item was changed: ----- Method: ObjectExplorer>>explorerKey:from: (in category 'menus') ----- explorerKey: aChar from: view "Similar to #genericMenu:..." | insideObject parentObject | currentSelection ifNotNil: [ insideObject := self object. parentObject := self parentObject. inspector ifNil: [inspector := Inspector new]. inspector inspect: parentObject; object: insideObject. aChar == $i ifTrue: [^ self inspectSelection]. aChar == $I ifTrue: [^ self exploreSelection]. aChar == $b ifTrue: [^ inspector browseMethodFull]. aChar == $h ifTrue: [^ inspector classHierarchy]. + aChar == $c ifTrue: [^ Clipboard clipboardText: self currentSelection key]. - aChar == $c ifTrue: [^ inspector copyName]. aChar == $p ifTrue: [^ inspector browseFullProtocol]. aChar == $N ifTrue: [^ inspector browseClassRefs]. aChar == $t ifTrue: [^ inspector tearOffTile]. aChar == $v ifTrue: [^ inspector viewerForValue]]. ^ self arrowKey: aChar from: view! Item was changed: ----- Method: ObjectExplorer>>getList (in category 'accessing') ----- getList + "This explorer shows bindings in a tree structure. Create the root binding here." + + ^ {self root}! - - ^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil) - ! Item was changed: ----- Method: ObjectExplorer>>initialExtent (in category 'user interface') ----- initialExtent + ^400@400! - ^300@500! Item was changed: + ----- Method: ObjectExplorer>>inspectSelection (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>inspectSelection (in category 'menus') ----- inspectSelection "Open an Inspector on the current selection" self object inspect! Item was changed: ----- Method: ObjectExplorer>>label (in category 'accessing') ----- label + ^ self rootObject printStringLimitedTo: 32! - ^ rootObject printStringLimitedTo: 32! Item was changed: + ----- Method: ObjectExplorer>>monitor: (in category 'menus - callbacks') ----- + monitor: aBinding + "Start stepping and watching the given binding for changes." + + aBinding ifNil: [ ^self ]. - ----- Method: ObjectExplorer>>monitor: (in category 'monitoring') ----- - monitor: anObjectExplorerWrapper - "Start stepping and watching the given wrapper for changes." - anObjectExplorerWrapper ifNil: [ ^self ]. self world ifNil: [ ^self ]. + self monitorList add: aBinding. + + self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 2000.! - self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString. - self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.! Item was changed: ----- Method: ObjectExplorer>>monitorList (in category 'monitoring') ----- monitorList + ^monitorList ifNil: [ monitorList := WeakOrderedCollection new ].! - ^monitorList ifNil: [ monitorList := WeakIdentityKeyDictionary new ].! Item was changed: + ----- Method: ObjectExplorer>>object (in category 'accessing - objects') ----- - ----- Method: ObjectExplorer>>object (in category 'accessing') ----- object + + ^ self currentSelection value! - ^currentSelection ifNotNil: [ :cs | cs withoutListWrapper ]! Item was changed: + ----- Method: ObjectExplorer>>objectReferencesToSelection (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>objectReferencesToSelection (in category 'menus') ----- objectReferencesToSelection "Open a browser on all references to the selected instance variable, if that's what currently selected. " self systemNavigation browseAllObjectReferencesTo: self object except: (Array with: self parentObject with: currentSelection with: inspector) ifNone: [:obj | self changed: #flash]. ! Item was removed: - ----- Method: ObjectExplorer>>openBrowser: (in category 'user interface') ----- - openBrowser: aClass - - ^ToolSet browseClass: aClass! Item was changed: ----- Method: ObjectExplorer>>openExplorerFor: (in category 'user interface') ----- openExplorerFor: anObject + "ObjectExplorer new openExplorerFor: Smalltalk." - " - ObjectExplorer new openExplorerFor: Smalltalk - " + ^ self openExplorerFor: anObject withLabel: nil! - | win | - win := (self explorerFor: anObject) openInWorld. - Cursor wait showWhile: - [win submorphs do: - [:sm| - (sm respondsTo: #expandRoots) ifTrue: - [sm expandRoots]]]. - ^self - ! Item was changed: ----- Method: ObjectExplorer>>openExplorerFor:withLabel: (in category 'user interface') ----- openExplorerFor: anObject withLabel: label "ObjectExplorer new openExplorerFor: Smalltalk withLabel: 'Smalltalk'" + ToolBuilder open: self label: label. + self rootObject: anObject.! - (self explorerFor: anObject withLabel: label) - openInWorld! Item was changed: + ----- Method: ObjectExplorer>>parentObject (in category 'accessing - objects') ----- - ----- Method: ObjectExplorer>>parentObject (in category 'accessing') ----- parentObject + + ^ self currentParent value! - currentSelection ifNil: [ ^nil ]. - currentSelection parent ifNil: [ ^rootObject ]. - ^currentSelection parent withoutListWrapper! Item was changed: + ----- Method: ObjectExplorer>>referencesToSelection (in category 'menus - callbacks') ----- - ----- Method: ObjectExplorer>>referencesToSelection (in category 'menus') ----- referencesToSelection "Open a browser on all references to the selected instance variable, if that's what's currently selected." | aClass sel | (aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash]. sel := self selector. self systemNavigation browseAllAccessesTo: sel from: aClass! Item was added: + ----- Method: ObjectExplorer>>root (in category 'accessing') ----- + root + + ^ root ifNil: [root := 'root' -> nil]! Item was changed: + ----- Method: ObjectExplorer>>rootObject (in category 'accessing - objects') ----- - ----- Method: ObjectExplorer>>rootObject (in category 'accessing') ----- rootObject + + ^ self root value! - ^ rootObject! Item was added: + ----- Method: ObjectExplorer>>rootObject: (in category 'accessing - objects') ----- + rootObject: anObject + + self root value: anObject. + + self changed: #label. + self changed: #getList. + self changed: #expandRootsRequested. + + self currentSelection: self getList first.! Item was changed: + ----- Method: ObjectExplorer>>selectedClass (in category 'accessing - other') ----- - ----- Method: ObjectExplorer>>selectedClass (in category 'menus') ----- selectedClass "Answer the class of the receiver's current selection" ^self doItReceiver class ! Item was changed: + ----- Method: ObjectExplorer>>selector (in category 'accessing - other') ----- - ----- Method: ObjectExplorer>>selector (in category 'accessing') ----- selector + + self flag: #deprecated. "mt: Who uses this? And why?" + self parentObject ifNil: [^ nil]. + (self parentObject class allInstVarNames includes: self currentSelection key) + ifTrue: [^ self currentSelection key asSymbol]. + ^ nil! - ^currentSelection ifNotNil: [ :cs | cs selector ]! Item was changed: ----- Method: ObjectExplorer>>step (in category 'monitoring') ----- step + "Let all views know that some of my objects need to be updated." + + self monitorList do: [ :object | + object ifNotNil: [self changed: #objectChanged with: object]]. + self monitorList ifEmpty: [ + ActiveWorld stopStepping: self selector: #step ].! - "If there's anything in my monitor list, see if the strings have changed." - | changes | - changes := false. - self monitorList keysAndValuesDo: [ :k :v | - k ifNotNil: [ - | string | - k refresh. - (string := k asString) ~= v ifTrue: [ self monitorList at: k put: string. changes := true ]. - ] - ]. - changes ifTrue: [ | sel | - sel := currentSelection. - self changed: #getList. - self noteNewSelection: sel. - ]. - self monitorList isEmpty ifTrue: [ ActiveWorld stopStepping: self selector: #step ].! Item was removed: - ----- Method: ObjectExplorer>>trash (in category 'menus') ----- - trash - "What goes in the bottom pane" - ^ ''! Item was removed: - ----- Method: ObjectExplorer>>trash: (in category 'menus') ----- - trash: newText - "Don't save it" - ^ true! Item was added: + ----- Method: PointerExplorer class>>nodeClass (in category 'as yet unclassified') ----- + nodeClass + + ^ PointerExplorerWrapper! Item was removed: - ----- Method: PointerExplorer>>getList (in category 'accessing') ----- - getList - ^Array with: (PointerExplorerWrapper with: rootObject name: rootObject identityHash asString model: self) - ! Item was added: + ----- Method: PointerExplorer>>rootObject: (in category 'accessing') ----- + rootObject: anObject + + self root key: anObject identityHash asString. + super rootObject: anObject.!

1 0

The Trunk: Morphic-mt.774.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.774.mcz ==================== Summary ==================== Name: Morphic-mt.774 Author: mt Time: 7 March 2015, 12:16:53.926 pm UUID: 2bd1bbc8-ce83-3a44-a72a-d514668e3f03 Ancestors: Morphic-topa.773 ObjectExplorerWrapper refactored. It now stores bindings as items because this simplifies the adaptation of ObjectExplorer to use PluggableTreeMorphs. A pluggable tree morph wants to hide all wrappers from the model. To still distinguish, for example, various 'nil' values, it is necessary to work with bindings. Those bindings are not the ones as stored internally in the class object but made up new. Look at #setItem:name:model:. =============== Diff against Morphic-topa.773 =============== Item was added: + ----- Method: ListItemWrapper>>item (in category 'accessing') ----- + item + ^ item! Item was added: + ----- Method: ListItemWrapper>>model (in category 'accessing') ----- + model + ^ model! Item was changed: + ----- Method: ListItemWrapper>>setItem: (in category 'initialization') ----- - ----- Method: ListItemWrapper>>setItem: (in category 'accessing') ----- setItem: anObject item := anObject! Item was changed: + ----- Method: ListItemWrapper>>setItem:model: (in category 'initialization') ----- - ----- Method: ListItemWrapper>>setItem:model: (in category 'accessing') ----- setItem: anObject model: aModel item := anObject. model := aModel.! Item was changed: ----- Method: ObjectExplorerWrapper>>asString (in category 'converting') ----- asString + | explorerString label separator | - | explorerString string separator | explorerString := + [self object asExplorerString] - [item asExplorerString] on: Error + do: ['<error: ', self object class name, ' in asExplorerString: evaluate "' , self itemName , ' asExplorerString" to debug>']. + (explorerString includes: Character cr) + ifTrue: [explorerString := explorerString withSeparatorsCompacted]. + + label := self itemName ifNil: ['']. + (label includes: Character cr) + ifTrue: [label := label withSeparatorsCompacted]. + - do: ['<error: ', item class name, ' in asExplorerString: evaluate "' , itemName , ' asExplorerString" to debug>']. separator := self class showContentsInColumns ifTrue: [String tab] + ifFalse: [label ifEmpty: [''] ifNotEmpty: [': ']]. + + ^ '{1}{2}{3}' format: {label. separator. explorerString}! - ifFalse: [': ']. - string := (itemName ifNotNil: [itemName, separator] ifNil: ['']) , explorerString. - (string includes: Character cr) - ifTrue: [^ string withSeparatorsCompacted]. - ^ string! Item was removed: - ----- Method: ObjectExplorerWrapper>>canBeDragged (in category 'as yet unclassified') ----- - canBeDragged - - ^false! Item was changed: ----- Method: ObjectExplorerWrapper>>contents (in category 'accessing') ----- contents + (self object respondsTo: #explorerContents) ifTrue: [^ self object explorerContents]. - (item respondsTo: #explorerContents) ifTrue: [^item explorerContents]. "For all others, show named vars first, then indexed vars" + ^(self object class allInstVarNames asOrderedCollection withIndexCollect: [:each :index | - ^(item class allInstVarNames asOrderedCollection withIndexCollect: [:each :index | self class + with: (self object instVarAt: index) - with: (item instVarAt: index) name: each + model: self object - model: item parent: self]) , + ((1 to: self object basicSize) collect: [:index | - ((1 to: item basicSize) collect: [:index | self class + with: (self object basicAt: index) - with: (item basicAt: index) name: index printString + model: self object - model: item parent: self])! Item was changed: ----- Method: ObjectExplorerWrapper>>hasContents (in category 'accessing') ----- hasContents + ^ self object hasContentsInExplorer - ^item hasContentsInExplorer ! Item was changed: ----- Method: ObjectExplorerWrapper>>icon (in category 'accessing') ----- icon "Answer a form to be used as icon" ^ Preferences visualExplorer + ifTrue: [(self object iconOrThumbnailOfSize: 12) - ifTrue: [(item iconOrThumbnailOfSize: 12) ifNil: [self class showContentsInColumns ifTrue: [ToolIcons iconNamed: #blank] ifFalse: [nil]]] ifFalse: [nil]! Item was changed: + ----- Method: ObjectExplorerWrapper>>itemName (in category 'accessing') ----- - ----- Method: ObjectExplorerWrapper>>itemName (in category 'converting') ----- itemName + + ^ self item key! - ^itemName! Item was added: + ----- Method: ObjectExplorerWrapper>>object (in category 'accessing') ----- + object + + ^ self item value! Item was added: + ----- Method: ObjectExplorerWrapper>>object: (in category 'accessing') ----- + object: anObject + + self item value: anObject.! Item was changed: + ----- Method: ObjectExplorerWrapper>>parent (in category 'accessing') ----- - ----- Method: ObjectExplorerWrapper>>parent (in category 'as yet unclassified') ----- parent + ^ parent! - ^parent! Item was removed: - ----- Method: ObjectExplorerWrapper>>parent: (in category 'as yet unclassified') ----- - parent: anObject - parent := anObject! Item was changed: ----- Method: ObjectExplorerWrapper>>refresh (in category 'monitoring') ----- refresh "hack to refresh item given an object and a string that is either an index or an instance variable name." + + self parent ifNil: [^ self]. [ | index | + (model class allInstVarNames includes: self itemName) + ifTrue: [ self object: (model instVarNamed: self itemName) ] + ifFalse: [ index := self itemName asNumber. + (index between: 1 and: model basicSize) ifTrue: [ self object: (model basicAt: index)]] + ] on: Error do: [ :ex | self object: nil ]! - (model class allInstVarNames includes: itemName) - ifTrue: [ item := model instVarNamed: itemName ] - ifFalse: [ index := itemName asNumber. - (index between: 1 and: model basicSize) ifTrue: [ item := model basicAt: index]] - ] on: Error do: [ :ex | item := nil ]! Item was removed: - ----- Method: ObjectExplorerWrapper>>selector (in category 'as yet unclassified') ----- - selector - parent ifNil: [ ^nil ]. - ^(parent withoutListWrapper class allInstVarNames includes: itemName) ifTrue: [ itemName asSymbol ]! Item was changed: + ----- Method: ObjectExplorerWrapper>>setItem:name:model: (in category 'initialization') ----- - ----- Method: ObjectExplorerWrapper>>setItem:name:model: (in category 'as yet unclassified') ----- setItem: anObject name: aString model: aModel + self setItem: aString -> anObject model: aModel.! - item := anObject. - model := aModel. - itemName := aString.! Item was changed: + ----- Method: ObjectExplorerWrapper>>setItem:name:model:parent: (in category 'initialization') ----- - ----- Method: ObjectExplorerWrapper>>setItem:name:model:parent: (in category 'as yet unclassified') ----- setItem: anObject name: aString model: aModel parent: itemParent + parent := itemParent. self setItem: anObject name: aString model: aModel!

1 0

The Trunk: ToolBuilder-Morphic-mt.95.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Marcel Taeumel uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-mt.95.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-mt.95 Author: mt Time: 7 March 2015, 12:12:08.671 pm UUID: f31dcf42-ecf7-8f41-9627-091e9f980483 Ancestors: ToolBuilder-Morphic-mt.94 Pluggable tree morph bug-fixed and extended to understand simple selections and custom node classes. Its companion -- PluggableTreeItemNode -- now speaks #parent and has a stub for #refresh. Preparation for refactored object explorer. =============== Diff against ToolBuilder-Morphic-mt.94 =============== Item was changed: ----- Method: MorphicToolBuilder>>buildPluggableTree: (in category 'pluggable widgets') ----- buildPluggableTree: aSpec | widget | widget := self treeClass new. self register: widget id: aSpec name. widget model: aSpec model. widget getSelectedPathSelector: aSpec getSelectedPath. widget setSelectedSelector: aSpec setSelected. + widget getSelectedSelector: aSpec getSelected. + widget setSelectedParentSelector: aSpec setSelectedParent. widget getChildrenSelector: aSpec getChildren. widget hasChildrenSelector: aSpec hasChildren. widget getLabelSelector: aSpec label. widget getIconSelector: aSpec icon. widget getHelpSelector: aSpec help. widget getMenuSelector: aSpec menu. widget keystrokeActionSelector: aSpec keyPress. + widget nodeClass: aSpec nodeClass. widget getRootsSelector: aSpec roots. widget autoDeselect: aSpec autoDeselect. widget dropItemSelector: aSpec dropItem. widget wantsDropSelector: aSpec dropAccept. widget dragItemSelector: aSpec dragItem. + widget columns: aSpec columns. self setFrame: aSpec frame in: widget. parent ifNotNil:[self add: widget to: parent]. " panes ifNotNil:[ aSpec roots ifNotNil:[panes add: aSpec roots]. ]. " ^widget! Item was changed: ListItemWrapper subclass: #PluggableTreeItemNode + instanceVariableNames: 'parent' - instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! + !PluggableTreeItemNode commentStamp: 'mt 3/7/2015 09:15' prior: 0! + Tree item for PluggableTreeMorph. My model is the tree morph.! - !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! - Tree item for PluggableTreeMorph.! Item was added: + ----- Method: PluggableTreeItemNode>>parent (in category 'accessing') ----- + parent + ^ parent! Item was added: + ----- Method: PluggableTreeItemNode>>parent: (in category 'accessing') ----- + parent: aNode + parent := aNode.! Item was added: + ----- Method: PluggableTreeItemNode>>refresh (in category 'as yet unclassified') ----- + refresh + "Todo. See ObjectExplorerWrapper >> #refresh."! Item was changed: SimpleHierarchicalListMorph subclass: #PluggableTreeMorph + instanceVariableNames: 'rootWrappers selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedParentSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector nodeClass' - instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0! A pluggable tree morph.! Item was changed: ----- Method: PluggableTreeMorph>>contentsOfNode: (in category 'node access') ----- contentsOfNode: node + | children | getChildrenSelector ifNil:[^#()]. children := model perform: getChildrenSelector with: node item. + ^children collect: [:item| + (self nodeClass with: item model: self) parent: node]! - ^children collect:[:item| PluggableTreeItemNode with: item model: self]! Item was added: + ----- Method: PluggableTreeMorph>>getCurrentSelectionItem (in category 'selection') ----- + getCurrentSelectionItem + "Our models are supposed to return real objects, not wrappers. See PluggableTreeItemNode." + + | selectedObject | + selectedObject := self getSelectedSelector + ifNil: [^ nil] + ifNotNil: [:symbol | model perform: symbol]. + ^ scroller submorphs + detect: [:each | each complexContents item = selectedObject] + ifFound: [:each | each complexContents] + ifNone: [nil]! Item was added: + ----- Method: PluggableTreeMorph>>getSelectedSelector (in category 'accessing') ----- + getSelectedSelector + ^getSelectionSelector! Item was added: + ----- Method: PluggableTreeMorph>>getSelectedSelector: (in category 'accessing') ----- + getSelectedSelector: aSymbol + getSelectionSelector := aSymbol.! Item was added: + ----- Method: PluggableTreeMorph>>nodeClass (in category 'accessing') ----- + nodeClass + ^ nodeClass ifNil: [PluggableTreeItemNode]! Item was added: + ----- Method: PluggableTreeMorph>>nodeClass: (in category 'accessing') ----- + nodeClass: aListWrapperClass + nodeClass := aListWrapperClass.! Item was removed: - ----- Method: PluggableTreeMorph>>roots (in category 'accessing') ----- - roots - ^roots! Item was removed: - ----- Method: PluggableTreeMorph>>roots: (in category 'accessing') ----- - roots: anArray - roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. - self list: roots.! Item was changed: + ----- Method: PluggableTreeMorph>>selectPath:in: (in category 'selection') ----- - ----- Method: PluggableTreeMorph>>selectPath:in: (in category 'updating') ----- selectPath: path in: listItem path isEmpty ifTrue: [^self setSelectedMorph: nil]. listItem withSiblingsDo: [:each | (each complexContents item = path first) ifTrue: [ each isExpanded ifFalse: [ each toggleExpandedState. self adjustSubmorphPositions. ]. each changed. path size = 1 ifTrue: [ ^self setSelectedMorph: each ]. each firstChild ifNil: [^self setSelectedMorph: nil]. ^self selectPath: path allButFirst in: each firstChild ]. ]. ^self setSelectedMorph: nil ! Item was changed: ----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') ----- setSelectedMorph: aMorph selectedWrapper := aMorph complexContents. + + "Let the model now about the selected object, not wrapper." + setSelectionSelector ifNotNil: [:symbol | - self selection: selectedWrapper. - setSelectedSelector ifNotNil:[ model + perform: symbol + with: (selectedWrapper ifNotNil: [:w | w item])]. + + "The model may not have access to the parent object in terms of this tree structure." + setSelectedParentSelector ifNotNil: [:symbol | + model + perform: symbol + with: (selectedWrapper ifNotNil: [:w | w parent ifNotNil: [:pw | pw item]])].! - perform: setSelectedSelector - with: (selectedWrapper ifNotNil:[selectedWrapper item]). - ].! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedParentSelector (in category 'accessing') ----- + setSelectedParentSelector + ^ setSelectedParentSelector! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedParentSelector: (in category 'accessing') ----- + setSelectedParentSelector: aSymbol + setSelectedParentSelector := aSymbol.! Item was changed: ----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') ----- setSelectedSelector + ^setSelectionSelector! - ^setSelectedSelector! Item was changed: ----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') ----- setSelectedSelector: aSymbol + setSelectionSelector := aSymbol! - setSelectedSelector := aSymbol! Item was changed: ----- Method: PluggableTreeMorph>>update: (in category 'updating') ----- update: what what ifNil:[^self]. what == getRootsSelector ifTrue:[ + self wrapRoots: (model perform: getRootsSelector). + ^ self]. + - self roots: (model perform: getRootsSelector) - ]. what == getSelectedPathSelector ifTrue:[ + self + selectPath: (model perform: getSelectedPathSelector) + in: (scroller submorphs at: 1 ifAbsent: [^self]). + ^ self]. + + what == #expandRootsRequested ifTrue: [ + self expandRoots. + ^ self]. + + super update: what. + ! - ^self selectPath: (model perform: getSelectedPathSelector) - in: (scroller submorphs at: 1 ifAbsent: [^self]) - ]. - ^super update: what! Item was added: + ----- Method: PluggableTreeMorph>>update:with: (in category 'updating') ----- + update: what with: anObject + + super update: what with: anObject. + + what == #objectChanged ifTrue: [ + self updateFromChangedObject: anObject].! Item was added: + ----- Method: PluggableTreeMorph>>updateFromChangedObject: (in category 'updating') ----- + updateFromChangedObject: anObject + + scroller submorphs + detect: [:morph | morph complexContents item == anObject] + ifFound: [:morph | self updateMorph: morph] + ifNone: ["Ignore the request. Object may not be visible anyway."].! Item was added: + ----- Method: PluggableTreeMorph>>updateMorph: (in category 'updating') ----- + updateMorph: morph + + morph complexContents refresh. + morph refresh. + + morph isExpanded + ifFalse: [self changed] + ifTrue: [ + morph + toggleExpandedState; + toggleExpandedState. + self adjustSubmorphPositions]. + ! Item was added: + ----- Method: PluggableTreeMorph>>updateNode: (in category 'node access') ----- + updateNode: node + ! Item was added: + ----- Method: PluggableTreeMorph>>wrapRoots: (in category 'updating') ----- + wrapRoots: someObjects + + rootWrappers := someObjects collect: [:item| + self nodeClass with: item model: self]. + self list: rootWrappers.!

1 0

The Trunk: ToolBuilder-Kernel-mt.65.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Marcel Taeumel uploaded a new version of ToolBuilder-Kernel to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Kernel-mt.65.mcz ==================== Summary ==================== Name: ToolBuilder-Kernel-mt.65 Author: mt Time: 7 March 2015, 12:08:48.345 pm UUID: fe29688a-cb67-3a48-980c-01ae7c7cf4dd Ancestors: ToolBuilder-Kernel-bf.64 Pluggable tree specs extended with the concepts of columns, simple selections, custom node classes, and parent selections. Preparation for refactored object explorer. =============== Diff against ToolBuilder-Kernel-bf.64 =============== Item was changed: PluggableWidgetSpec subclass: #PluggableTreeSpec + instanceVariableNames: 'roots getSelectedPath setSelected getSelected setSelectedParent getChildren hasChildren label icon unusedVar menu keyPress wantsDrop dropItem dropAccept autoDeselect dragItem nodeClass columns' - instanceVariableNames: 'roots getSelectedPath setSelected getChildren hasChildren label icon unusedVar menu keyPress wantsDrop dropItem dropAccept autoDeselect dragItem' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableTreeSpec commentStamp: 'mvdg 3/21/2008 20:59' prior: 0! A 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. Instance variables: roots <Symbol> The message to retrieve the roots of the tree. getSelectedPath <Symbol> The message to retrieve the selected path in the tree. setSelected <Symbol> The message to set the selected item in the tree. getChildren <Symbol> The message to retrieve the children of an item hasChildren <Symbol> The message to query for children of an item label <Symbol> The message to query for the label of an item. icon <Symbol> The message to query for the icon of an item. help <Symbol> The message to query for the help of an item. menu <Symbol> The message to query for the tree's menu keyPress <Symbol> The message to process a keystroke. wantsDrop <Symbol> The message to query whether a drop might be accepted. dropItem <Symbol> The message to drop an item. enableDrag <Boolean> Enable dragging from this tree. autoDeselect <Boolean> Whether the tree should allow automatic deselection or not. unusedVar (unused) This variable is a placeholder to fix problems with loading packages in 3.10.! Item was added: + ----- Method: PluggableTreeSpec>>columns (in category 'accessing') ----- + columns + ^ columns! Item was added: + ----- Method: PluggableTreeSpec>>columns: (in category 'accessing') ----- + columns: columnSpecs + columns := columnSpecs.! Item was added: + ----- Method: PluggableTreeSpec>>getSelected (in category 'accessing') ----- + getSelected + ^ getSelected! Item was added: + ----- Method: PluggableTreeSpec>>getSelected: (in category 'accessing') ----- + getSelected: aSymbol + "Indicate a single node in the tree. Only works if that node is visible, too. Use #getSelectedPath otherwise." + + getSelected := aSymbol.! Item was added: + ----- Method: PluggableTreeSpec>>nodeClass (in category 'accessing') ----- + nodeClass + ^ nodeClass! Item was added: + ----- Method: PluggableTreeSpec>>nodeClass: (in category 'accessing') ----- + nodeClass: aListWrapperClass + nodeClass := aListWrapperClass.! Item was added: + ----- Method: PluggableTreeSpec>>setSelectedParent (in category 'accessing') ----- + setSelectedParent + ^ setSelectedParent! Item was added: + ----- Method: PluggableTreeSpec>>setSelectedParent: (in category 'accessing') ----- + setSelectedParent: aSymbol + setSelectedParent := aSymbol!

1 0

The Trunk: TrueType-topa.32.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

Tobias Pape uploaded a new version of TrueType to project The Trunk: http://source.squeak.org/trunk/TrueType-topa.32.mcz ==================== Summary ==================== Name: TrueType-topa.32 Author: topa Time: 7 March 2015, 2:19:21.165 am UUID: b69e6550-31b2-40db-8ff2-e5e990b214e7 Ancestors: TrueType-topa.31 Fix TrueType-topa.31 for Microsoft-encoded names and language tags =============== Diff against TrueType-topa.31 =============== Item was changed: ----- Method: TTFileDescription>>processNamingTable: (in category 'ttf tables') ----- processNamingTable: fontFile "copyright CHARPTR The font's copyright notice. familyName CHARPTR The font's family name. subfamilyName CHARPTR The font's subfamily name. uniqueName CHARPTR A unique identifier for this font. fullName CHARPTR The font's full name (a combination of familyName and subfamilyName). versionName CHARPTR The font's version string. " + | nRecords initialOffset storageOffset format | - | nRecords initialOffset storageOffset | initialOffset := fontFile position. + format := fontFile nextNumber: 2. + format = 0 ifFalse: [self error: 'Cannot handle format 1 naming tables']. - fontFile skip: 2. "Skip format selector" "Get the number of name records" nRecords := fontFile nextNumber: 2. "Offset from the beginning of this table" storageOffset := (fontFile nextNumber: 2) + initialOffset. 1 to: nRecords do:[:i| | pID sID lID nID length offset string | fontFile position: initialOffset + 6 + ((i-1) * 12). pID := fontFile nextNumber: 2. sID := fontFile nextNumber: 2. lID := fontFile nextNumber: 2. nID := fontFile nextNumber: 2. length := fontFile nextNumber: 2. offset := fontFile nextNumber: 2. "Read only Macintosh or Microsoft strings" (pID = 1 or:[pID = 3 and:[sID = 1]]) ifTrue:[ "MS uses Unicode all others single byte" "multiBytes := pID = 3." fontFile position: storageOffset+offset. string := (fontFile next: length) asString. pID = 3 ifTrue:[ | keep | keep := true. string := string select:[:ch| keep := keep not]. ]. + "Select only English names, prefer Macintosh" + ((pID = 1 and: [lID = 0]) or: [pID = 3 and: [lID = 16r0409]]) ifTrue: [ + nID caseOf: { + "[0] -> [copyright := string]." + [1] -> [(pID = 1 or:[familyName == nil]) ifTrue:[familyName := string]]. + [2] -> [(pID = 1 or:[subfamilyName == nil]) ifTrue:[subfamilyName := string]]. + "[3] -> [(pID = 1 or:[uniqueName == nil]) ifTrue:[uniqueName := string]]." + "[4] -> [(pID = 1 or:[fullName == nil]) ifTrue:[fullName := string]]." + "[5] -> [(pID = 1 or:[versionName == nil]) ifTrue:[versionName := string]]." + "[6] -> [(pID = 1 or:[postscriptName == ni]) ifTrue:[postscriptName := string]]." + "[7] -> [(pID = 1 or:[trademark == nil]) ifTrue:[trademark := string]]." + } otherwise:["ignore"]. + ] - nID caseOf: { - "Select only English names, prefer Macintosh" - "[0] -> [copyright := string]." - [1] -> [(lID = 0 and: [pID = 1 or:[familyName == nil]]) ifTrue:[familyName := string]]. - [2] -> [(lID = 0 and: [pID = 1 or:[subfamilyName == nil]]) ifTrue:[subfamilyName := string]]. - "[3] -> [(lID = 0 and: [pID = 1 or:[uniqueName == nil]]) ifTrue:[uniqueName := string]]." - "[4] -> [(lID = 0 and: [pID = 1 or:[fullName == nil]]) ifTrue:[fullName := string]]." - "[5] -> [(lID = 0 and: [pID = 1 or:[versionName == nil]]) ifTrue:[versionName := string]]." - "[6] -> [(lID = 0 and: [pID = 1 or:[postscriptName == ni]l]) ifTrue:[postscriptName := string]]." - "[7] -> [lpID = 0 and: [pID = 1 or:[trademark == nil]]) ifTrue:[trademark := string]]." - } otherwise:["ignore"]. ]. ]. ! Item was changed: ----- Method: TTFontReader>>processNamingTable: (in category 'processing') ----- processNamingTable: entry "copyright CHARPTR The font's copyright notice. familyName CHARPTR The font's family name. subfamilyName CHARPTR The font's subfamily name. uniqueName CHARPTR A unique identifier for this font. fullName CHARPTR The font's full name (a combination of familyName and subfamilyName). versionName CHARPTR The font's version string. + " | nRecords initialOffset format storageOffset strings | - " | nRecords initialOffset storageOffset strings | strings := Array new: 8. strings atAllPut:''. initialOffset := entry offset. + format := entry nextUShort. + format = 0 ifFalse: [self error: 'Cannot handle format 1 naming tables']. - entry skip: 2. "Skip format selector" "Get the number of name records" nRecords := entry nextUShort. "Offset from the beginning of this table" storageOffset := entry nextUShort + initialOffset. 1 to: nRecords do:[:i| | pID sID lID nID length offset multiBytes string | pID := entry nextUShort. sID := entry nextUShort. lID := entry nextUShort. nID := entry nextUShort. length := entry nextUShort. offset := entry nextUShort. "Read only Macintosh or Microsoft strings" (pID = 1 or:[pID = 3 and:[sID = 1]]) ifTrue:[ "MS uses Unicode all others single byte" multiBytes := pID = 3. string := entry stringAt: storageOffset + offset length: length multiByte: multiBytes. + + "Select only English names. + Note: We prefer Macintosh strings about everything." + ((pID = 1 and: [lID = 0]) or: [pID = 3 and: [lID = 16r0409]]) ifTrue: [ + "Put the name at the right location." + nID < strings size ifTrue:[ + (pID = 1 or:[(strings at: nID+1) = '']) + ifTrue:[strings at: nID+1 put: string]. + ]. - "Put the name at the right location. - Note: We prefer Macintosh strings about everything else and use only English names." - nID < strings size ifTrue:[ - (lID = 0 and: [pID = 1 or:[(strings at: nID+1) = '']]) - ifTrue:[strings at: nID+1 put: string]. ]. ]. ]. fontDescription setStrings: strings.!

1 0

The Inbox: KernelTests-cbc.291.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

A new version of KernelTests was added to project The Inbox: http://source.squeak.org/inbox/KernelTests-cbc.291.mcz ==================== Summary ==================== Name: KernelTests-cbc.291 Author: cbc Time: 6 March 2015, 3:52:01.005 pm UUID: 54afce93-39e9-4c4a-92a4-ecbe32540c69 Ancestors: KernelTests-ul.290, KernelTests-cbc.278 Added DateAndTimeArithmeticTest - to test adding things to DateAndTime instances. This includes things like: DateAndTime now + 3 days. Test convering adding various durations (like above) as well as adding strings, numbers, Timespans, Times, and DateAndTimes. Also tests subtracting the same. Added DurationArithmeticTest - tests expected outcomes of adding durations together, including the generic ones (resulting in GenericDuration instances). Also, tested for certain tricky leapYear conditions when adding years. =============== Diff against KernelTests-ul.290 =============== Item was added: + TestCase subclass: #DateAndTimeArithmeticTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'KernelTests-Chronology'! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddDateAndTime1 (in category 'testing') ----- + testAddDateAndTime1 + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + (DateAndTime year: 2014 month: 3 day: 31)) = (DateAndTime year: 2014 month: 1 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddDateAndTime2 (in category 'testing') ----- + testAddDateAndTime2 + self assert: ((DateAndTime year: 2014 month: 3 day: 31) + (DateAndTime year: 2014 month: 1 day: 31)) = (DateAndTime year: 2014 month: 3 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddDays (in category 'testing') ----- + testAddDays + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 days) = (DateAndTime year: 2014 month: 2 day: 2)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddHours (in category 'testing') ----- + testAddHours + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 hours) = (DateAndTime year: 2014 month: 1 day: 31 hour: 2 minute: 0)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddIntegers (in category 'testing') ----- + testAddIntegers + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2) = (DateAndTime year: 2014 month: 1 day: 31 hour: 0 minute: 0 second: 0 nanoSecond: 000000002 offset: DateAndTime localOffset)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMinutes (in category 'testing') ----- + testAddMinutes + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 minutes) = (DateAndTime year: 2014 month: 1 day: 31 hour: 0 minute: 2)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMonthTimespan1 (in category 'testing') ----- + testAddMonthTimespan1 + self assert: ((DateAndTime year: 2014 month: 1 day: 1) + (Month month: 1 year: 2015) + = (DateAndTime year: 2014 month: 2 day: 1)). + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMonthTimespan2 (in category 'testing') ----- + testAddMonthTimespan2 + self assert: ((DateAndTime year: 2014 month: 1 day: 1) + (Month month: 2 year: 2004) + = (DateAndTime year: 2014 month: 1 day: 30)). + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMonthTimespan3 (in category 'testing') ----- + testAddMonthTimespan3 + self assert: ((DateAndTime year: 2014 month: 1 day: 1) + (Month month: 2 year: 2005) + = (DateAndTime year: 2014 month: 1 day: 29)). + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMonths1 (in category 'testing') ----- + testAddMonths1 + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 1 month) = (DateAndTime year: 2014 month: 2 day: 28)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMonths2 (in category 'testing') ----- + testAddMonths2 + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 months) = (DateAndTime year: 2014 month: 3 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddMonths4 (in category 'testing') ----- + testAddMonths4 + self assert: ((DateAndTime year: 2004 month: 1 day: 31) + 1 month) = (DateAndTime year: 2004 month: 2 day: 29)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddNanoSeconds (in category 'testing') ----- + testAddNanoSeconds + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 nanoSeconds) = (DateAndTime year: 2014 month: 1 day: 31 hour: 0 minute: 0 second: 0 nanoSecond: 000000002 offset: DateAndTime localOffset)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddSeconds (in category 'testing') ----- + testAddSeconds + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 seconds) = (DateAndTime year: 2014 month: 1 day: 31 hour: 0 minute: 0 second: 2)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddStrings (in category 'testing') ----- + testAddStrings + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + '02:00:00:00') = (DateAndTime year: 2014 month: 2 day: 2)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddTime (in category 'testing') ----- + testAddTime + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + ('02:00:00' asTime)) = (DateAndTime year: 2014 month: 1 day: 31 hour: 2 minute: 0)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddTimespan (in category 'testing') ----- + testAddTimespan + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + + ((DateAndTime year: 2014 month: 1 day: 1) to: (DateAndTime year: 2014 month: 1 day: 3))) = (DateAndTime year: 2014 month: 2 day: 2) + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddWeeks (in category 'testing') ----- + testAddWeeks + self assert: ((DateAndTime year: 2014 month: 1 day: 31) + 2 weeks) = (DateAndTime year: 2014 month: 2 day: 14) + + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddYears1 (in category 'testing') ----- + testAddYears1 + self assert: ((DateAndTime year: 2006 month: 1 day: 31) + 2 years) = (DateAndTime year: 2008 month: 1 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddYears2 (in category 'testing') ----- + testAddYears2 + self assert: ((DateAndTime year: 2007 month: 1 day: 31) + 2 years) = (DateAndTime year: 2009 month: 1 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddYears3 (in category 'testing') ----- + testAddYears3 + self assert: ((DateAndTime year: 2004 month: 2 day: 29) + 1 year) = (DateAndTime year: 2005 month: 2 day: 28)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddYears4 (in category 'testing') ----- + testAddYears4 + self assert: ((DateAndTime year: 2003 month: 4 day: 1) + 2 years) = (DateAndTime year: 2005 month: 4 day: 1)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddYears5 (in category 'testing') ----- + testAddYears5 + self assert: ((DateAndTime year: 2003 month: 4 day: 1) + 1 years) = (DateAndTime year: 2004 month: 4 day: 1)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testAddYears6 (in category 'testing') ----- + testAddYears6 + self assert: ((DateAndTime year: 2011 month: 3 day: 1) + 1 years) = (DateAndTime year: 2012 month: 3 day: 1) + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractDateAndTime1 (in category 'testing') ----- + testSubtractDateAndTime1 + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - (DateAndTime year: 2014 month: 1 day: 31)) = 59 days! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractDateAndTime2 (in category 'testing') ----- + testSubtractDateAndTime2 + self assert: ((DateAndTime year: 2014 month: 1 day: 31) - (DateAndTime year: 2014 month: 3 day: 31)) = 59 days negated! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractDays (in category 'testing') ----- + testSubtractDays + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 days) = (DateAndTime year: 2014 month: 3 day: 29)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractHours (in category 'testing') ----- + testSubtractHours + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 hours) = (DateAndTime year: 2014 month: 3 day: 30 hour: 22 minute: 0)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractIntegers (in category 'testing') ----- + testSubtractIntegers + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2) = (DateAndTime year: 2014 month: 3 day: 30 hour: 23 minute: 59 second: 59 nanoSecond: 999999998 offset: DateAndTime localOffset)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractMinutes (in category 'testing') ----- + testSubtractMinutes + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 minutes) = (DateAndTime year: 2014 month: 3 day: 30 hour: 23 minute: 58)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractMonths1 (in category 'testing') ----- + testSubtractMonths1 + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 1 month) = (DateAndTime year: 2014 month: 2 day: 28)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractMonths2 (in category 'testing') ----- + testSubtractMonths2 + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 months) = (DateAndTime year: 2014 month: 1 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractMonths3 (in category 'testing') ----- + testSubtractMonths3 + self assert: ((DateAndTime year: 2014 month: 3 day: 14) - 1 month) = (DateAndTime year: 2014 month: 2 day: 14)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractMonths4 (in category 'testing') ----- + testSubtractMonths4 + self assert: ((DateAndTime year: 2004 month: 3 day: 31) - 1 month) = (DateAndTime year: 2004 month: 2 day: 29)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractNanoSeconds (in category 'testing') ----- + testSubtractNanoSeconds + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 nanoSeconds) = (DateAndTime year: 2014 month: 3 day: 30 hour: 23 minute: 59 second: 59 nanoSecond: 999999998 offset: DateAndTime localOffset)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractSeconds (in category 'testing') ----- + testSubtractSeconds + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 seconds) = (DateAndTime year: 2014 month: 3 day: 30 hour: 23 minute: 59 second: 58)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractStrings (in category 'testing') ----- + testSubtractStrings + self assert: ((DateAndTime year: 2014 month: 1 day: 31) - '02:00:00:00') = (DateAndTime year: 2014 month: 1 day: 29)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractTime (in category 'testing') ----- + testSubtractTime + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - ('02:00:00' asTime)) = (DateAndTime year: 2014 month: 3 day: 30 hour: 22 minute: 0)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractTimespan (in category 'testing') ----- + testSubtractTimespan + self assert: ((DateAndTime year: 2014 month: 3 day: 31) + - ((DateAndTime year: 2014 month: 3 day: 1) to: (DateAndTime year: 2024 month: 1 day: 3))) = ('30:00:00:00' asDuration)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractWeeks (in category 'testing') ----- + testSubtractWeeks + self assert: ((DateAndTime year: 2014 month: 3 day: 31) - 2 weeks) = (DateAndTime year: 2014 month: 3 day: 17) + + ! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractYears1 (in category 'testing') ----- + testSubtractYears1 + self assert: ((DateAndTime year: 2008 month: 1 day: 31) - 2 years) = (DateAndTime year: 2006 month: 1 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractYears2 (in category 'testing') ----- + testSubtractYears2 + self assert: ((DateAndTime year: 2009 month: 1 day: 31) - 2 years) = (DateAndTime year: 2007 month: 1 day: 31)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractYears3 (in category 'testing') ----- + testSubtractYears3 + self assert: ((DateAndTime year: 2005 month: 2 day: 28) - 1 year) = (DateAndTime year: 2004 month: 2 day: 28)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractYears4 (in category 'testing') ----- + testSubtractYears4 + self assert: ((DateAndTime year: 2005 month: 4 day: 1) - 2 years) = (DateAndTime year: 2003 month: 4 day: 1)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractYears5 (in category 'testing') ----- + testSubtractYears5 + self assert: ((DateAndTime year: 2004 month: 4 day: 1) - 1 years) = (DateAndTime year: 2003 month: 4 day: 1)! Item was added: + ----- Method: DateAndTimeArithmeticTest>>testSubtractYears6 (in category 'testing') ----- + testSubtractYears6 + self assert: ((DateAndTime year: 2011 month: 3 day: 1) - 1 years) = (DateAndTime year: 2010 month: 3 day: 1)! Item was added: + TestCase subclass: #DurationArithmeticTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'KernelTests-Chronology'! Item was added: + ----- Method: DurationArithmeticTest>>testAddDayDurations (in category 'as yet unclassified') ----- + testAddDayDurations + self assert: (1 day + 2 days = 3 days)! Item was added: + ----- Method: DurationArithmeticTest>>testAddDayHourDurations (in category 'as yet unclassified') ----- + testAddDayHourDurations + self assert: (1 day + 2 hours = '1:02:00:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddDayMonthDurations (in category 'as yet unclassified') ----- + testAddDayMonthDurations + self assert: (1 day + 2 months = (GenericDuration new + 1 day + 2 months))! Item was added: + ----- Method: DurationArithmeticTest>>testAddHourDayDurations (in category 'as yet unclassified') ----- + testAddHourDayDurations + self assert: (1 hour + 2 days = '2:01:00:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddHourMinuteDurations (in category 'as yet unclassified') ----- + testAddHourMinuteDurations + self assert: (1 hour + 2 minutes = '0:01:02:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddMinuteHourDurations (in category 'as yet unclassified') ----- + testAddMinuteHourDurations + self assert: (1 minute + 2 hours = '0:02:01:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddMinuteSecondDurations (in category 'as yet unclassified') ----- + testAddMinuteSecondDurations + self assert: (1 minute + 2 seconds = '0:00:01:02' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddMonthDayDurations (in category 'as yet unclassified') ----- + testAddMonthDayDurations + self assert: (1 month + 2 days = (GenericDuration new + 1 month + 2 days))! Item was added: + ----- Method: DurationArithmeticTest>>testAddMonthYearDurations (in category 'as yet unclassified') ----- + testAddMonthYearDurations + self assert: (1 month + 2 years = (GenericDuration new + 1 month + 2 years))! Item was added: + ----- Method: DurationArithmeticTest>>testAddNanoSecondSecondDurations (in category 'as yet unclassified') ----- + testAddNanoSecondSecondDurations + self assert: (1 nanoSeconds + 2 seconds = '0:00:00:02.000000001' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddSecondMinuteDurations (in category 'as yet unclassified') ----- + testAddSecondMinuteDurations + self assert: (1 second + 2 minutes = '0:00:02:01' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddSecondNanoSecondDurations (in category 'as yet unclassified') ----- + testAddSecondNanoSecondDurations + self assert: (1 second + 2 nanoSeconds = '0:00:00:01.000000002' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testAddYearMonthDurations (in category 'as yet unclassified') ----- + testAddYearMonthDurations + self assert: (1 year + 2 months = (GenericDuration new + 1 year + 2 months))! Item was added: + ----- Method: DurationArithmeticTest>>testDayDurationAssociativeSubtractionWithDateTime (in category 'as yet unclassified') ----- + testDayDurationAssociativeSubtractionWithDateTime + self assert: (((DateAndTime year: 2014 month: 1 day: 31) - 1 hour - 1 day) + = ((DateAndTime year: 2014 month: 1 day: 31) - (1 hour + 1 day)))! Item was added: + ----- Method: DurationArithmeticTest>>testDayDurationAssociativeWithDateTime (in category 'as yet unclassified') ----- + testDayDurationAssociativeWithDateTime + self assert: (((DateAndTime year: 2014 month: 1 day: 31) + 1 hour + 1 day) + = ((DateAndTime year: 2014 month: 1 day: 31) + (1 hour + 1 day)))! Item was added: + ----- Method: DurationArithmeticTest>>testGenericDurationAddition (in category 'as yet unclassified') ----- + testGenericDurationAddition + self assert: (((1 month + 1 month) + (1 year + 1 year)) + = (1 month + 1 month + 1 year + 1 year))! Item was added: + ----- Method: DurationArithmeticTest>>testGenericDurationSubtraction (in category 'as yet unclassified') ----- + testGenericDurationSubtraction + self assert: (((1 month + 1 month) - (1 year + 1 year)) + = (1 month + 1 month - 1 year - 1 year))! Item was added: + ----- Method: DurationArithmeticTest>>testMonthDurationAssociativeSubtractionWithDateTime (in category 'as yet unclassified') ----- + testMonthDurationAssociativeSubtractionWithDateTime + self assert: (((DateAndTime year: 2014 month: 1 day: 31) - 1 month - 1 day) + = ((DateAndTime year: 2014 month: 1 day: 31) - (1 month + 1 day)))! Item was added: + ----- Method: DurationArithmeticTest>>testMonthDurationAssociativeWithDateTime (in category 'as yet unclassified') ----- + testMonthDurationAssociativeWithDateTime + self assert: (((DateAndTime year: 2014 month: 1 day: 31) + 1 month + 1 day) + = ((DateAndTime year: 2014 month: 1 day: 31) + (1 month + 1 day)))! Item was added: + ----- Method: DurationArithmeticTest>>testMonthDurationNotCommutative (in category 'as yet unclassified') ----- + testMonthDurationNotCommutative + self deny: ((1 month + 2 days) = (2 days + 1 month))! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractDayDurations (in category 'as yet unclassified') ----- + testSubtractDayDurations + self assert: (2 days - 1 day = 1 day)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractDayHourDurations (in category 'as yet unclassified') ----- + testSubtractDayHourDurations + self assert: (1 day - 2 hours = '0:22:00:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractDayMonthDurations (in category 'as yet unclassified') ----- + testSubtractDayMonthDurations + self assert: (1 day - 2 months = (GenericDuration new + 1 day - 2 months))! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractHourDayDurations (in category 'as yet unclassified') ----- + testSubtractHourDayDurations + self assert: (1 hour - 2 days = '-1:23:00:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractHourMinuteDurations (in category 'as yet unclassified') ----- + testSubtractHourMinuteDurations + self assert: (1 hour - 2 minutes = '0:00:58:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractMinuteHourDurations (in category 'as yet unclassified') ----- + testSubtractMinuteHourDurations + self assert: (1 minute - 2 hours = '-0:01:59:00' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractMinuteSecondDurations (in category 'as yet unclassified') ----- + testSubtractMinuteSecondDurations + self assert: (1 minute - 2 seconds = '0:00:00:58' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractMonthDayDurations (in category 'as yet unclassified') ----- + testSubtractMonthDayDurations + self assert: (1 month - 2 days = (GenericDuration new + 1 month - 2 days))! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractMonthYearDurations (in category 'as yet unclassified') ----- + testSubtractMonthYearDurations + self assert: (1 month - 2 years = (GenericDuration new + 1 month - 2 years))! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractNanoSecondSecondDurations (in category 'as yet unclassified') ----- + testSubtractNanoSecondSecondDurations + self assert: (1 nanoSeconds - 2 seconds = '-0:00:00:01.999999999' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractSecondMinuteDurations (in category 'as yet unclassified') ----- + testSubtractSecondMinuteDurations + self assert: (1 second - 2 minutes = '-0:00:01:59' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractSecondNanoSecondDurations (in category 'as yet unclassified') ----- + testSubtractSecondNanoSecondDurations + self assert: (1 second - 2 nanoSeconds = '0:00:00:00.999999998' asDuration)! Item was added: + ----- Method: DurationArithmeticTest>>testSubtractYearMonthDurations (in category 'as yet unclassified') ----- + testSubtractYearMonthDurations + self assert: (1 year - 2 months = (GenericDuration new + 1 year - 2 months))! Item was added: + ----- Method: DurationArithmeticTest>>testYearDurationAssociativeSubtractionWithDateTime (in category 'as yet unclassified') ----- + testYearDurationAssociativeSubtractionWithDateTime + self assert: (((DateAndTime year: 2014 month: 1 day: 31) - 1 year - 1 day) + = ((DateAndTime year: 2014 month: 1 day: 31) - (1 year + 1 day)))! Item was added: + ----- Method: DurationArithmeticTest>>testYearDurationAssociativeWithDateTime (in category 'as yet unclassified') ----- + testYearDurationAssociativeWithDateTime + self assert: (((DateAndTime year: 2014 month: 1 day: 31) + 1 year + 1 day) + = ((DateAndTime year: 2014 month: 1 day: 31) + (1 year + 1 day)))! Item was added: + ----- Method: DurationArithmeticTest>>testYearDurationNotCommutative (in category 'as yet unclassified') ----- + testYearDurationNotCommutative + self deny: ((1 year + 2 days) = (2 days + 1 year))!

1 0

The Inbox: Kernel-cbc.910.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

A new version of Kernel was added to project The Inbox: http://source.squeak.org/inbox/Kernel-cbc.910.mcz ==================== Summary ==================== Name: Kernel-cbc.910 Author: cbc Time: 6 March 2015, 3:48:56.226 pm UUID: 6af9b576-3666-7444-ad16-9b84461a4dd0 Ancestors: Kernel-mt.909, Kernel-cbc.872 Changes to support adding months and years to a DateAndTime, such as: DateAndTime now + 2 months and DateAndTimeNow - 5 years This requires retro-fitting the + and - in DateAndTime to a double dispatch system, and requires changes in Collections as well (to support + and - with String representations). Added support for chaining durations (such as 1 month + 1 day). =============== Diff against Kernel-mt.909 =============== Item was changed: ----- Method: DateAndTime>>+ (in category 'ansi protocol') ----- + + aDuration + "aDuration is one of: Duration, GenericDuration, GenericMonth, or GenericYear." + ^aDuration addToDateTime: self - + operand - "operand conforms to protocol Duration" - - | ticks | - ticks := self ticks + (operand asDuration ticks) . - - ^ self class basicNew - ticks: ticks - offset: self offset; - yourself ! Item was changed: ----- Method: DateAndTime>>- (in category 'ansi protocol') ----- - operand + "operand is one of: Duration, GenericDuration, GenericMonth, or GenericYear; or a DateAndTime or Timespan." + ^operand subtractFromDateTime: self - "operand conforms to protocol DateAndTime or protocol Duration" - - ^ (operand respondsTo: #asDateAndTime) - ifTrue: - [ | lticks rticks | - lticks := self asLocal ticks. - - rticks := operand asDateAndTime asLocal ticks. - Duration - seconds: (SecondsInDay *(lticks first - rticks first)) + - (lticks second - rticks second) - nanoSeconds: (lticks third - rticks third) ] - - ifFalse: - - [ self + (operand negated) ] ! Item was added: + ----- Method: DateAndTime>>addToDateTime: (in category 'ansi protocol') ----- + addToDateTime: aDateAndTime + ^self asDuration addToDateTime: aDateAndTime + ! Item was added: + ----- Method: DateAndTime>>addToDuration: (in category 'ansi protocol') ----- + addToDuration: aDuration + ^Duration nanoSeconds: (self asNanoSeconds + aDuration asNanoSeconds) + ! Item was added: + ----- Method: DateAndTime>>subtractFromDateTime: (in category 'ansi protocol') ----- + subtractFromDateTime: aDateAndTime + | lticks rticks | + lticks := aDateAndTime asLocal ticks. + rticks := self asLocal ticks. + ^Duration + seconds: (SecondsInDay * (lticks first - rticks first)) + + (lticks second - rticks second) + nanoSeconds: (lticks third - rticks third)! Item was added: + ----- Method: DateAndTime>>subtractFromDuration: (in category 'ansi protocol') ----- + subtractFromDuration: aDuration + ^Duration nanoSeconds: (aDuration asNanoSeconds - self asNanoSeconds)! Item was changed: ----- Method: Duration>>+ (in category 'ansi protocol') ----- + operand + "operand is a type of Duration" + ^operand addToDuration: self + ! - - "operand is a Duration" ^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds)! Item was changed: ----- Method: Duration>>- (in category 'ansi protocol') ----- - operand + "operand is a type of Duration" + ^operand subtractFromDuration: self + ! - "operand is a Duration" ^ self + operand negated! Item was added: + ----- Method: Duration>>addToDateTime: (in category 'ansi protocol') ----- + addToDateTime: aDateAndTime + | ticks | + ticks := self ticks + (aDateAndTime ticks) . + ^ aDateAndTime class basicNew + ticks: ticks + offset: aDateAndTime offset; + yourself + ! Item was added: + ----- Method: Duration>>addToDuration: (in category 'ansi protocol') ----- + addToDuration: aDuration + ^self class nanoSeconds: (self asNanoSeconds + aDuration asNanoSeconds) + ! Item was added: + ----- Method: Duration>>subtractFromDateTime: (in category 'ansi protocol') ----- + subtractFromDateTime: aDateAndTime + ^self copy negated addToDateTime: aDateAndTime! Item was added: + ----- Method: Duration>>subtractFromDuration: (in category 'ansi protocol') ----- + subtractFromDuration: aDuration + ^self class nanoSeconds: (aDuration asNanoSeconds - self asNanoSeconds) + ! Item was added: + Object subclass: #GenericDuration + instanceVariableNames: 'sequence' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Chronology'! + + !GenericDuration commentStamp: 'cbc 9/21/2014 22:07' prior: 0! + The GenericDuration class exists to support simple DateAndTime arithmetic (also including Timespan, such as Date). This class supports chains of different duration arthmetic with each other, such as: + 1 year + 2 months + 3 days + 4 hours + 5 minuts + 6 seconds + 7 nanoSeconds + Instances of GenericDuration should be created by adding (or subtracting)2 or more durations with each other, including other instances of GenericDuration. + + You cannot ask a GenericDuration how long it is. This is a nonsensical question if a year or month is involved, as those are only resolvable once it is place into relationship to an actual date. + + GenericDuration are associate, but not commutative. That is + 1 month + 31 days ~= 31 days + 1 month + but + ((1 month + 1 year) + 31 days) = (1 month + (1 year + 31 days)) + ! Item was added: + ----- Method: GenericDuration>>+ (in category 'ansii protocol') ----- + + aDuration + "aDuration is one of the families of Duration. Not that if it isn't, it will fail, but only when addng to a DateAndTime or Timespan, not before!!" + aDuration class = self class + ifTrue: [sequence addAllLast: aDuration sequence] + ifFalse: [sequence addLast: aDuration copy] + ! Item was added: + ----- Method: GenericDuration>>- (in category 'ansii protocol') ----- + - aDuration + "aDuration is one of the families of Duration. Not that if it isn't, it will fail, but only when addng to a DateAndTime or Timespan, not before!!" + aDuration class = self class + ifTrue: [sequence addAllLast: (aDuration sequence collect: [:s| s copy negated])] + ifFalse: [sequence addLast: aDuration copy negated]! Item was added: + ----- Method: GenericDuration>>= (in category 'ansii protocol') ----- + = aGenericDuration + ^aGenericDuration hasSameSequence: sequence! Item was added: + ----- Method: GenericDuration>>addToDateTime: (in category 'ansii protocol') ----- + addToDateTime: aDateAndTime + ^sequence inject: aDateAndTime into: [:result :duration | result + duration ]! Item was added: + ----- Method: GenericDuration>>addToDuration: (in category 'ansii protocol') ----- + addToDuration: aDuration + sequence addFirst: aDuration copy! Item was added: + ----- Method: GenericDuration>>hasSameSequence: (in category 'ansii protocol') ----- + hasSameSequence: testSequence + ^sequence hasEqualElements: testSequence! Item was added: + ----- Method: GenericDuration>>hash (in category 'ansii protocol') ----- + hash + ^(sequence collect: #hash) sum hash! Item was added: + ----- Method: GenericDuration>>initialize (in category 'initialize-release') ----- + initialize + sequence := OrderedCollection new.! Item was added: + ----- Method: GenericDuration>>printOn: (in category 'squeak protocol') ----- + printOn: stream + sequence do: [:msg| msg printOn: stream] separatedBy: [stream nextPutAll: ' + ']! Item was added: + ----- Method: GenericDuration>>sequence (in category 'accessing') ----- + sequence + + ^ sequence! Item was added: + ----- Method: GenericDuration>>subtractFromDateTime: (in category 'ansii protocol') ----- + subtractFromDateTime: aDateAndTime + ^sequence inject: aDateAndTime into: [:result :duration | result + duration copy negated ]! Item was added: + ----- Method: GenericDuration>>subtractFromDuration: (in category 'ansii protocol') ----- + subtractFromDuration: aDuration + sequence addFirst: aDuration copy negated! Item was added: + Object subclass: #GenericMonth + instanceVariableNames: 'number' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Chronology'! + + !GenericMonth commentStamp: 'cbc 9/21/2014 22:01' prior: 0! + The GenericMonth class exists to support simple DateAndTime arithmetic with months (also including Timespan, such as Date). This class is the mechanism behind: + DateAndTime now + 3 months + Instances of this class should be created by sending #month or #months to an integer (other types of number result in unspecified results). + (note that sending #month to any number will result in either exactly 1 month or -1 month, ignoring the actual number you send it too.) + + Thse are the rules about what a 'month' is: + 1: If you add a month, you want the result to be in the next calendar month, never the following one. + 2: If you add a month, you want the same day of the month if possible, and if not (becaue the next month has less days), then the closest that you can get to it. + 4: If you add more than 1 month, you want to end up in the right calendar month that you would expect, and as close to the starting day of the month as you can. + 3: If you subtract a month, you want it in the previous calendar month, and as close to the starting day of the month as you can get. + + So, adding 1 month to August 31 would give September 30th; adding 2 months to August 31 would give October 31st. And adding 1 month to September 30th would give October 30th. + + + ! Item was added: + ----- Method: GenericMonth class>>months: (in category 'as yet unclassified') ----- + months: aNumber + ^self new number: aNumber! Item was added: + ----- Method: GenericMonth>>+ (in category 'ansiProtocol') ----- + + aDuration + "aDuration is one of the families of Duration. Not that if it isn't, it will fail, but only when addng to a DateAndTime or Timespan, not before!!" + ^GenericDuration new + self + aDuration! Item was added: + ----- Method: GenericMonth>>- (in category 'ansiProtocol') ----- + - aDuration + "aDuration is one of the families of Duration. Not that if it isn't, it will fail, but only when addng to a DateAndTime or Timespan, not before!!" + ^GenericDuration new + self - aDuration! Item was added: + ----- Method: GenericMonth>>= (in category 'ansiProtocol') ----- + = aGenericMonth + ^aGenericMonth class = GenericMonth + and: [aGenericMonth number = number]! Item was added: + ----- Method: GenericMonth>>addNegativeToDateTime: (in category 'ansiProtocol') ----- + addNegativeToDateTime: aDateAndTime + | next | + next := (1 to: number abs) inject: aDateAndTime into: [:end :mnth| + end - end dayOfMonth days. + ]. + ^next - (next dayOfMonth - aDateAndTime dayOfMonth max: 0) days! Item was added: + ----- Method: GenericMonth>>addToDateTime: (in category 'ansiProtocol') ----- + addToDateTime: aDateAndTime + | next | + number < 0 ifTrue: [^self addNegativeToDateTime: aDateAndTime]. + next := (1 to: number) inject: aDateAndTime into: [:end :mnth| + next := end + end daysInMonth days. + next dayOfMonth < end dayOfMonth + ifTrue: [next := next - next dayOfMonth days]. + next + ]. + ^next + ((next daysInMonth min: aDateAndTime dayOfMonth) - next dayOfMonth) days! Item was added: + ----- Method: GenericMonth>>addToDuration: (in category 'ansiProtocol') ----- + addToDuration: aDuration + ^GenericDuration new + aDuration + self + ! Item was added: + ----- Method: GenericMonth>>hash (in category 'ansiProtocol') ----- + hash + ^number hash! Item was added: + ----- Method: GenericMonth>>negated (in category 'accessing') ----- + negated + number := number negated! Item was added: + ----- Method: GenericMonth>>number (in category 'accessing') ----- + number + + ^ number! Item was added: + ----- Method: GenericMonth>>number: (in category 'accessing') ----- + number: anObject + + number := anObject! Item was added: + ----- Method: GenericMonth>>printOn: (in category 'squeak protocol') ----- + printOn: stream + stream nextPutAll: number asString; nextPutAll: ' month'. + number abs = 1 ifFalse: [stream nextPut: $s].! Item was added: + ----- Method: GenericMonth>>subtractFromDateTime: (in category 'ansiProtocol') ----- + subtractFromDateTime: aDateAndTime + ^self copy negated addToDateTime: aDateAndTime + ! Item was added: + ----- Method: GenericMonth>>subtractFromDuration: (in category 'ansiProtocol') ----- + subtractFromDuration: aDuration + ^GenericDuration new + aDuration - self! Item was added: + Object subclass: #GenericYear + instanceVariableNames: 'number' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Chronology'! + + !GenericYear commentStamp: 'cbc 9/21/2014 22:00' prior: 0! + The GenericYear class exists to support simple DateAndTime arithmetic with years (also including Timespan, such as Date). This class is the mechanism behind: + DateAndTime now + 3 years + Instances of this class should be created by sending #year or #years to an integer (other types of number result in unspecified results). + (note that sending #year to any number will result in either exactly 1 year or -1 year, ignoring the actual number you send it too.) + + Thse are the rules about what a 'year' is: + 1: If you add a year, you want the result to be in the next year, never the following one; it needs to end up in the same month as the starting month; and it needs to be the same day of the month if possible as the starting date, and if not (becaue the next years month has less days such as leap year to non-leap year), then the closest that you can get to it. + 4: If you add more than 1 year, you want to end up in the right year, same calendar month that you would expect, and as close to the starting day of the month as you can. + 3: If you subtract a year, you want it in the previous year and same calendar month, and as close to the starting day of the month as you can get.! Item was added: + ----- Method: GenericYear class>>years: (in category 'as yet unclassified') ----- + years: aNumber + ^self new number: aNumber! Item was added: + ----- Method: GenericYear>>+ (in category 'ansiProtocol') ----- + + aDuration + "aDuration is one of the families of Duration. Not that if it isn't, it will fail, but only when addng to a DateAndTime or Timespan, not before!!" + ^GenericDuration new + self + aDuration! Item was added: + ----- Method: GenericYear>>- (in category 'ansiProtocol') ----- + - aDuration + "aDuration is one of the families of Duration. Not that if it isn't, it will fail, but only when addng to a DateAndTime or Timespan, not before!!" + ^GenericDuration new + self - aDuration! Item was added: + ----- Method: GenericYear>>= (in category 'ansiProtocol') ----- + = aGenericYear + ^aGenericYear class = GenericYear + and: [aGenericYear number = number]! Item was added: + ----- Method: GenericYear>>addNegativeToDateTime: (in category 'ansiProtocol') ----- + addNegativeToDateTime: aDateAndTime + | next | + next := (1 to: number abs) inject: aDateAndTime into: [:end :mnth| + end - end dayOfYear days. + ]. + next := next - (next month - aDateAndTime month) months. + ^next - (next dayOfMonth - aDateAndTime dayOfMonth max: 0) days! Item was added: + ----- Method: GenericYear>>addToDateTime: (in category 'ansiProtocol') ----- + addToDateTime: aDateAndTime + | next | + number < 0 ifTrue: [^self addNegativeToDateTime: aDateAndTime]. + ^(1 to: number) inject: aDateAndTime into: [:end :mnth| + next := end + ((end isLeapYear and: [end month > 2]) + ifTrue: [end daysInYear - 1] "We've already factored in the extra leap year" + ifFalse: [end daysInYear] "either not a leap year, or we need the extra day" + ) days. + "if we are now in a leap year, we may need to already factor in the extra day" + (next month > 2 and: [next isLeapYear and: [end dayOfMonth ~= next dayOfMonth]]) ifTrue: [next := next + 1 days]. + "If we have leaped out of a leap year, and we were on Feb 29th, we need to back up to Feb 28th" + next month > end month ifTrue: [next := next - next dayOfMonth days]. + "If we have leeped out of a leap year, and we were on Mar 1st, we need to increment by 1 to get back where we should be" + next month < end month ifTrue: [next := next + 1 day]. + next + ]. + ! Item was added: + ----- Method: GenericYear>>addToDuration: (in category 'ansiProtocol') ----- + addToDuration: aDuration + ^GenericDuration new + aDuration + self + ! Item was added: + ----- Method: GenericYear>>hash (in category 'ansiProtocol') ----- + hash + ^number hash! Item was added: + ----- Method: GenericYear>>negated (in category 'accessing') ----- + negated + number := number negated! Item was added: + ----- Method: GenericYear>>number (in category 'accessing') ----- + number + + ^ number! Item was added: + ----- Method: GenericYear>>number: (in category 'accessing') ----- + number: anObject + + number := anObject! Item was added: + ----- Method: GenericYear>>printOn: (in category 'squeak protocol') ----- + printOn: stream + stream nextPutAll: number asString; nextPutAll: ' year'. + number abs = 1 ifFalse: [stream nextPut: $s].! Item was added: + ----- Method: GenericYear>>subtractFromDateTime: (in category 'ansiProtocol') ----- + subtractFromDateTime: aDateAndTime + ^self copy negated addToDateTime: aDateAndTime! Item was added: + ----- Method: GenericYear>>subtractFromDuration: (in category 'ansiProtocol') ----- + subtractFromDuration: aDuration + ^GenericDuration new + aDuration - self! Item was changed: ----- Method: Month>>previous (in category 'squeak protocol') ----- previous + ^ self class starting: (self start - 1 month)! - ^ self class starting: (self start - 1)! Item was added: + ----- Method: Number>>addToDateTime: (in category 'arithmetic') ----- + addToDateTime: aDateAndTime + "Utilized when adjusting DateAndTimes. Such as: + DateAndTime now + 2 + Not expected to be used outside of that system. + Note, also, that this keeps the long-standing tradition that we are adding nanoseconds to the DateAndTime." + ^self asDuration addToDateTime: aDateAndTime + ! Item was added: + ----- Method: Number>>month (in category 'converting') ----- + month + + ^ self sign months! Item was added: + ----- Method: Number>>months (in category 'converting') ----- + months + + ^ GenericMonth months: self! Item was added: + ----- Method: Number>>subtractFromDateTime: (in category 'arithmetic') ----- + subtractFromDateTime: aDateAndTime + "Utilized when adjusting DateAndTimes. Such as: + DateAndTime now - 2 + Not expected to be used outside of that system. + Note, also, that this keeps the long-standing tradition that we are subtracting nanoseconds to the DateAndTime." + ^self asDuration subtractFromDateTime: aDateAndTime + ! Item was added: + ----- Method: Number>>year (in category 'converting') ----- + year + + ^ self sign years! Item was added: + ----- Method: Number>>years (in category 'converting') ----- + years + + ^ GenericYear years: self! Item was added: + ----- Method: Time>>addToDateTime: (in category 'squeak protocol') ----- + addToDateTime: aDateAndTime + ^self asDuration addToDateTime: aDateAndTime + ! Item was added: + ----- Method: Time>>addToDuration: (in category 'ansi protocol') ----- + addToDuration: aDuration + ^Duration nanoSeconds: (self asNanoSeconds + aDuration asNanoSeconds) + ! Item was added: + ----- Method: Time>>subtractFromDateTime: (in category 'squeak protocol') ----- + subtractFromDateTime: aDateAndTime + ^self asDuration subtractFromDateTime: aDateAndTime + ! Item was added: + ----- Method: Time>>subtractFromDuration: (in category 'ansi protocol') ----- + subtractFromDuration: aDuration + ^Duration nanoSeconds: (aDuration asNanoSeconds - self asNanoSeconds)! Item was changed: ----- Method: Timespan>>+ (in category 'ansi protocol') ----- + + aDuration + "aDuration is one of: Duration, GenericDuration, GenericMonth, or GenericYear." + ^self class starting: (aDuration addToDateTime: self start) duration: self duration + ! - + operand - "operand conforms to protocol Duration" - - - ^ self class starting: (self start + operand) duration: self duration! Item was changed: ----- Method: Timespan>>- (in category 'ansi protocol') ----- - operand + | result | + "operand is one of: Duration, GenericDuration, GenericMonth, or GenericYear; or a DateAndTime or Timespan." + result := operand subtractFromDateTime: self start. + ^result class = DateAndTime + ifTrue: [ self class starting: result duration: self duration] + ifFalse: [result] - "operand conforms to protocol DateAndTime or protocol Duration" - - ^ (operand respondsTo: #asDateAndTime) - - ifTrue: [ self start - operand ] - - ifFalse: [ self + (operand negated) ] ! Item was added: + ----- Method: Timespan>>addToDateTime: (in category 'squeak protocol') ----- + addToDateTime: aDateAndTime + ^duration addToDateTime: aDateAndTime + ! Item was added: + ----- Method: Timespan>>subtractFromDateTime: (in category 'squeak protocol') ----- + subtractFromDateTime: aDateAndTime + ^start subtractFromDateTime: aDateAndTime!

1 0

The Inbox: Collections-cbc.604.mcz
by commits＠source.squeak.org 07 Mar '15

07 Mar '15

A new version of Collections was added to project The Inbox: http://source.squeak.org/inbox/Collections-cbc.604.mcz ==================== Summary ==================== Name: Collections-cbc.604 Author: cbc Time: 6 March 2015, 3:44:37.262 pm UUID: 0513e699-e650-2340-8505-70e368dd9c64 Ancestors: Collections-eem.603, Collections-cbc.582 Changes to support adding and subtracting strings from DateAndTimes. Supports syntax such as: DateAndTime now + '02:00:00:00' and DateAndTime now - '02:00:00:00' =============== Diff against Collections-eem.603 =============== Item was added: + ----- Method: String>>addToDateTime: (in category 'arithmetic') ----- + addToDateTime: aDateAndTime + "Utilized when adjusting DateAndTimes. Such as: + DateAndTime now + '02: 00:00:00' + Not expected to be used outside of that system." + ^self asDuration addToDateTime: aDateAndTime + ! Item was added: + ----- Method: String>>subtractFromDateTime: (in category 'arithmetic') ----- + subtractFromDateTime: aDateAndTime + "Utilized when adjusting DateAndTimes. Such as: + DateAndTime now - '02: 00:00:00' + Not expected to be used outside of that system." + ^self asDuration subtractFromDateTime: aDateAndTime + !

1 0

← Newer
1
...
24
25
26
27
28
29
30
31
32
Older →

Jump to page: