"
COPYRIGHT (c) 1999 by eXept Software AG
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libwidg2' }"
HierarchicalList subclass:#HierarchicalFileList
instanceVariableNames:'matchBlock showCursor mountPoints indicatorList indicatorTask
sortBlock'
classVariableNames:''
poolDictionaries:''
category:'Views-Support'
!
HierarchicalItem subclass:#HierarchicalFileItem
instanceVariableNames:'fileName icon fileInfo suffix owner group'
classVariableNames:'LastUIDToUserNameMapping LastGIDToGroupNameMapping'
poolDictionaries:''
privateIn:HierarchicalFileList
!
HierarchicalFileList::HierarchicalFileItem subclass:#File
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:HierarchicalFileList
!
HierarchicalFileList::HierarchicalFileItem subclass:#Directory
instanceVariableNames:'modificationTime fetchOperation'
classVariableNames:''
poolDictionaries:''
privateIn:HierarchicalFileList
!
HierarchicalFileList::Directory subclass:#RemoteDirectory
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:HierarchicalFileList
!
!HierarchicalFileList class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1999 by eXept Software AG
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
! !
!HierarchicalFileList class methodsFor:'examples'!
examples
"
[exBegin]
|top sel list|
list := HierarchicalFileList new.
list directory:(Filename homeDirectory).
list showRoot:false.
list matchBlock:[:fn :isDir| true ].
top := StandardSystemView new; extent:300@300.
sel := ScrollableView for:HierarchicalListView miniScroller:true
origin:0.0@0.0 corner:1.0@1.0 in:top.
sel doubleClickAction:[:i| (list at:i) toggleExpand ].
sel indicatorAction:[:i| (list at:i) toggleExpand ].
sel list:list.
list monitoringTaskDelay:0.2.
top open.
[exEnd]
"
! !
!HierarchicalFileList class methodsFor:'helpers'!
forInfoItem:aItem
"instance creation helper
"
| info fileType retItem|
info := aItem info.
fileType := aItem type.
retItem := self itemFor:aItem fileName fileType:fileType.
retItem fileInfo:info.
^ retItem
!
itemFor:aFileOrDirectoryName fileType:fileType
"instance creation helper
"
fileType == #directory ifTrue:[
^ Directory fileName:aFileOrDirectoryName.
].
fileType == #remoteDirectory ifTrue:[
^ RemoteDirectory fileName:aFileOrDirectoryName.
].
^ File fileName:aFileOrDirectoryName.
! !
!HierarchicalFileList methodsFor:'accessing'!
directory
"returns the root directory or nil
"
^ root notNil ifTrue:[root fileName] ifFalse:[nil]
!
directory:aDirectory
"set the root directory or nil
"
self directory:aDirectory expand:true
!
directory:aDirectory expand:doExpand
"set the root directory or nil
"
|directory|
"/ must explicitly enabled by user: ca
"/ monitoringTaskDelay := 1.
(aDirectory notNil and:[(directory := aDirectory asFilename) exists]) ifTrue:[
directory isDirectory ifFalse:[
directory := directory directory
]
] ifFalse:[
directory := nil
].
directory = self directory ifFalse:[
directory notNil ifTrue:[
directory := self class itemFor:directory fileType:#directory.
doExpand ifTrue:[ directory setExpanded:true ].
].
self root:directory
].
!
root:aRoot
"stop update-task
"
self criticalDo:[
indicatorList ifNotNil:[
indicatorList do:[:el| el resetFetchIndicator ].
indicatorList removeAll.
]
].
aRoot ifNotNil:[
self showRoot ifFalse:[aRoot setExpanded:true ]
].
^ super root:aRoot
! !
!HierarchicalFileList methodsFor:'actions'!
matchBlock
"set the matchBlock - if non-nil, it controls which files are visible.
"
^ matchBlock
!
matchBlock:aBlock
"set the matchBlock - if non-nil, it controls which files are visible.
"
matchBlock := aBlock.
root notNil ifTrue:[
self recursionLock critical:[
self stopMonitoringTask.
root matchBlockChanged.
].
self startMonitoringTask.
].
!
sortBlock
"set the matchBlock - if non-nil, it controls which files are visible.
"
sortBlock isNil ifTrue:[
sortBlock := [:a :b|
a isDirectory == b isDirectory ifTrue:[a baseName <= b baseName]
ifFalse:[a isDirectory].
]
].
^ sortBlock
!
sortBlock:aBlock
"set the matchBlock - if non-nil, it controls which files are visible.
"
sortBlock := aBlock.
root notNil ifTrue:[
self recursionLock critical:[
self stopMonitoringTask.
root sortBlockChanged.
].
self startMonitoringTask.
].
! !
!HierarchicalFileList methodsFor:'private monitoring task'!
monitoringCycle
"the block evaluated by the monitoring task; test whether directory is expanded
otherwise we have not to evaluate the directory contents.
think about remote file-systems
"
|index item mountInfo|
"/ mountPoints isNil ifTrue:[
"/ mountPoints := OperatingSystem mountPoints.
"/ ].
item := root.
index := showRoot ifTrue:[1] ifFalse:[0].
item isNil ifTrue:[
item := self at:index ifAbsent:nil.
].
[item notNil] whileTrue:[
item isDirectory ifTrue:[
item monitoringCycle
].
"/ item isDirectory ifTrue:[
"/ (item getChildren isNil) ifTrue:[
"/ "/ care for auto-mount points - we dont want to look into those automatically
"/ "/ i.e. user must explicitely click into them
"/ mountInfo := mountPoints detect:[:mInfo | mInfo mountPointPath = item fileName name] ifNone:nil.
"/ (mountInfo notNil and:[mountInfo isRemote]) ifTrue:[
"/ "/ type := #remoteFileSystem.
"/ item readChildren
"/ ] ifFalse:[
"/ "/ must read children info
"/ item readChildren
"/ ].
"/ ] ifFalse:[
"/ "/ children already initialized; thus we can update the contents
"/ item monitoringCycle
"/ ].
"/ ].
Processor yield.
index := index + 1.
item := self at:index ifAbsent:nil.
].
! !
!HierarchicalFileList methodsFor:'protocol'!
childrenFor:anItem
"returns all visible children derived from the physical
directory contents.
"
|contents list matchBlock|
anItem isDirectory ifFalse:[^ #()].
contents := DirectoryContents directoryNamed:anItem fileName.
contents ifNil:[ ^ #() ].
list := OrderedCollection new.
matchBlock := self matchBlockFor:anItem.
matchBlock isNil ifTrue:[
matchBlock := [:fn :isDir | true].
].
contents itemsDo:[:item |
|fn isDir type|
fn := item fileName.
isDir := item isDirectory.
(matchBlock value:fn value:isDir) ifTrue:[
|hierarchicalItem|
hierarchicalItem := self class forInfoItem:item.
list add:hierarchicalItem.
]
].
list isEmpty ifTrue:[^ #()].
list sort:self sortBlock.
^ list
!
hasChildrenFor:anItem
"returns true if the physical directory contains at least
one visible item otherwise false.
"
|block|
anItem isDirectory ifFalse:[
^ false
].
(block := self matchBlockFor:anItem) isNil ifTrue:[
block := [:aFilename :isDirectory| true ]
].
^ DirectoryContents directoryNamed:(anItem fileName) detect:block
!
iconFor:anItem
"returns the icon for an item
"
(anItem isExpanded and:[anItem hasChildren]) ifTrue:[
^ FileBrowser iconForKeyMatching:#directoryOpen
].
(anItem isRemoteDirectory) ifTrue:[
^ FileBrowser iconForKeyMatching:#directoryNetwork
].
^ FileBrowser iconForFile:(anItem fileName)
!
matchBlockFor:anItem
"get the matchBlock - if non-nil, it controls which files are
visible within the physical directory
"
^ matchBlock
! !
!HierarchicalFileList methodsFor:'searching'!
findLastForFile:aPathOrFile
"find last item which matches the path or file
returns the item or nil if not contained in self
"
|file searchItem rootDir rootComponents searchComponents|
(aPathOrFile isNil or:[root isNil]) ifTrue:[
^ nil
].
file := aPathOrFile asFilename.
file exists ifFalse:[ ^ nil ].
rootDir := root fileName asAbsoluteFilename.
"/ file := file asAbsoluteFilename.
"/ (file pathName startsWith:(rootDir pathName)) ifFalse:[
(file asString startsWith:(rootDir pathName)) ifFalse:[
"not included"
^ nil
].
rootComponents := rootDir components.
searchComponents := file components.
searchItem := root.
searchComponents from:(rootComponents size + 1) do:[:aName| |child|
child := searchItem detect:[:el| el baseName = aName ] ifNone:nil.
child isNil ifTrue:[ ^ searchItem ].
searchItem := child.
].
^ searchItem
! !
!HierarchicalFileList methodsFor:'update'!
startIndicatorValidationFor:anItem
"an item will be registered for an indication update
"
|prio|
self criticalDo:[
indicatorList size == 0 ifTrue:[
indicatorList := OrderedCollection new.
] ifFalse:[
indicatorList removeIdentical:anItem ifAbsent:nil.
].
"/ indicatorList addFirst:anItem.
indicatorList add:anItem.
indicatorTask ifNil:[
prio := Processor activePriority.
indicatorTask := [ self updateIndicatorCycle. ] forkAt:(prio - 1).
indicatorTask priorityRange:(prio-1 to:prio).
]
].
!
stopIndicatorValidationFor:anItem
"stop the indicator validation for an item
"
self criticalDo:[
indicatorList ifNotNil:[
indicatorList removeIdentical:anItem ifAbsent:nil.
anItem resetFetchIndicator.
]
].
!
updateIndicatorCycle
"run fetching indicator task cycle.
This is done in the background to avoid long startup
delays, in case the indicator information takes long to
gather (i.e. when reading directories)
"
|repeat task item|
repeat := true.
task := indicatorTask.
[ [ task notNil ] whileTrue:[
self criticalDo:[
( dependents size ~~ 0 "/ no dependencies (stop task)
and:[indicatorList size ~~ 0] "/ nothing to do
) ifTrue:[
item := indicatorList removeFirst.
(self includesIdentical:item) ifFalse:[
"/ no longer visible
item resetFetchIndicator.
item := nil
]
] ifFalse:[
item := indicatorTask := task := nil
]
].
item ifNotNil:[
item fetchIndicator.
Processor yield.
].
]
] valueNowOrOnUnwindDo:[
task ifNotNil:[
"/ oops, process terminated
self criticalDo:[
"/ test whether a new task already started
indicatorTask == task ifTrue:[
indicatorTask := nil
]
]
]
].
! !
!HierarchicalFileList::HierarchicalFileItem class methodsFor:'instance creation'!
fileName:aFileName
"instance creation
"
^ self new fileName:aFileName.
!
fileName:aFileName isDirectory:isDirectory
"instance creation
"
|item|
item := isDirectory ifTrue:[HierarchicalFileList::Directory new] ifFalse:[HierarchicalFileList::File new].
item fileName:aFileName.
^ item
! !
!HierarchicalFileList::HierarchicalFileItem methodsFor:'accessing'!
baseName
"returns the baseName
"
^ fileName baseName.
"/ ^ baseName
!
changed:aParameter
"the item changed; raise change notification
"
aParameter == #icon ifTrue:[ icon := nil ].
super changed:aParameter.
!
fileInfo:something
"set the value of the instance variable 'fileInfo' (automatically generated)"
fileInfo := something.
!
fileName
"returns the fileName
"
^ fileName
!
fileName:fname
"instance creation
"
fileName := fname.
"/ baseName := fname baseName.
!
fileSize
"returns the fileSize
"
self getFileInfo.
fileInfo isNil ifTrue:[^ nil].
^ fileInfo fileSize
!
getFileInfo
fileInfo isNil ifTrue:[
self isRemoteDirectory ifTrue:[
"/ do not access, to avoid automount
] ifFalse:[
fileInfo := fileName linkInfo.
fileInfo isNil ifTrue:[
fileInfo := fileName info.
].
].
].
^ fileInfo
!
group
"returns the printable group
"
|gid|
group isNil ifTrue:[
self getFileInfo.
fileInfo isNil ifTrue:[^ '???'].
gid := fileInfo gid.
(LastGIDToGroupNameMapping notNil and:[gid == LastGIDToGroupNameMapping key]) ifTrue:[
group := LastGIDToGroupNameMapping value
] ifFalse:[
group := OperatingSystem getGroupNameFromID:gid.
LastGIDToGroupNameMapping := gid -> group.
]
].
^ group
!
icon
"returns the icon key
"
|model|
icon isNil ifTrue:[
model := self model.
model ifNil:[^ nil].
icon := model iconFor:self.
].
^ icon.
!
label
"returns the printable name, the baseName
"
^ self baseName
!
modificationTime
"returns the absolute time of modification
"
self getFileInfo.
fileInfo isNil ifTrue:[^ nil].
^ fileInfo modificationTime
!
owner
"returns the printable owner
"
|uid|
owner isNil ifTrue:[
self getFileInfo.
fileInfo isNil ifTrue:[^ '???'].
uid := fileInfo uid.
(LastUIDToUserNameMapping notNil and:[uid == LastUIDToUserNameMapping key]) ifTrue:[
owner := LastUIDToUserNameMapping value
] ifFalse:[
owner := OperatingSystem getUserNameFromID:uid.
LastUIDToUserNameMapping := uid -> owner.
]
].
^ owner
!
pathName
"returns the pathName
"
^ fileName pathName
!
permissions
"returns the permissions as printable string
"
|mode permissionString|
self getFileInfo.
fileInfo isNil ifTrue:[^ '???'.].
mode := fileInfo mode.
permissionString := String new:9 withAll:$-.
1 to:9 by:3 do:[:i|
(mode bitAt:i ) == 1 ifTrue:[permissionString at:10 - i put:$x].
(mode bitAt:i + 1) == 1 ifTrue:[permissionString at:9 - i put:$w].
(mode bitAt:i + 2) == 1 ifTrue:[permissionString at:8 - i put:$r].
].
^ permissionString
!
suffix
"returns the suffix of the file
"
suffix isNil ifTrue:[
(OperatingSystem isUNIXlike and:[(self baseName at:1) == $.]) ifTrue:[
suffix := ''.
] ifFalse:[
suffix := fileName suffix.
]
].
^ suffix
! !
!HierarchicalFileList::HierarchicalFileItem methodsFor:'invalidate'!
invalidate
"invalidate the contents
"
self invalidateRepairNow:false
!
invalidateRepairNow
"invalidate the contents; repair now
"
self invalidateRepairNow:true
!
invalidateRepairNow:doRepair
"invalidate the contents; dependent on the boolean
do repair immediately
"
!
matchBlockChanged
"called if the matchBlock changed
"
!
sortBlockChanged
"called if the matchBlock changed
"
! !
!HierarchicalFileList::HierarchicalFileItem methodsFor:'printing'!
printString
^ super printString, ' for: ', self fileName asString
! !
!HierarchicalFileList::HierarchicalFileItem methodsFor:'protocol'!
flushChildren
"flush the children because node not visible ....
canbe redefined by subclass
"
children := nil.
! !
!HierarchicalFileList::HierarchicalFileItem methodsFor:'queries'!
isDirectory
^ false
!
isRemoteDirectory
^ false
!
time
^ self valueAt:#modified
! !
!HierarchicalFileList::File methodsFor:'accessing'!
children
"always returns an empty list
"
^ #()
! !
!HierarchicalFileList::File methodsFor:'queries'!
hasChildren
"always returns false
"
^ false
! !
!HierarchicalFileList::Directory class methodsFor:'documentation'!
documentation
"
[Instance variables:]
fetchOperation <Symbol/Boolean> nil if children is nil, no information about has children
#fetching registered in list to be updated for indication
#hasChildren registered in list to be updated for indication
#hasNoChildren has children but children list might be nil (remote)
"
! !
!HierarchicalFileList::Directory methodsFor:'accessing'!
children
"returns the list of children
"
|model|
children ifNotNil:[ ^ children ].
model := self model.
model ifNil:[ ^ nil ].
model criticalDo:[
children ifNil:[ self readChildren ].
].
^ children
!
flushChildren
"flush the children because node not visible ....
"
children ifNotNil:[
"keep hasChildren information
"
children size ~~ 0 ifTrue:[ fetchOperation := #hasChildren ]
ifFalse:[ fetchOperation := #hasNoChildren ].
children := nil.
].
!
readChildren
"reads the list of children
"
|model list hadChildren hasChildren|
model := self model.
model ifNil:[
"/ must reread later
fetchOperation := modificationTime := children := nil.
^ nil
].
hadChildren := children size ~~ 0.
"/ set to suppress reading of children
children := #().
fetchOperation := nil.
modificationTime := fileName modificationTime.
model stopIndicatorValidationFor:self.
list := model childrenFor:self.
list size ~~ 0 ifTrue:[
list do:[:aChild| aChild parent:self].
children := list.
].
hasChildren := children size ~~ 0.
hasChildren ~~ hadChildren ifTrue:[
self changed:#redraw
].
^ children
! !
!HierarchicalFileList::Directory methodsFor:'accessing-hierarchy'!
collapse
super collapse.
children notNil ifTrue:[
children do:[:el| el flushChildren ]
].
!
expand
"expand children; must redefine to raise a notification
if children are not yet initialized and after initialization empty.
"
super expand.
!
recursiveCollapse
super recursiveCollapse.
!
recursiveExpand
"redefined to expand
"
self expand
! !
!HierarchicalFileList::Directory methodsFor:'fetching'!
basicFetchIndicator
|hasChildren|
hasChildren := DirectoryContents directoryNamed:fileName
detect:(self model matchBlock).
hasChildren ifTrue:[
fetchOperation := #hasChildren
] ifFalse:[
fetchOperation := #hasNoChildren
].
children isNil ifTrue:[
"setup modification time to suppress monitorCycle
"
modificationTime := fileName modificationTime.
].
!
fetchIndicator
"fetch the indicator value which indicates whether children exists or not
called by the list
"
children ifNotNil:[
"/ children already read
fetchOperation := nil.
^ self
].
fetchOperation ~~ #fetching ifTrue:[
"/ children will be updated ....
^ self
].
"/ suppress restart of fetchIndicator
self basicFetchIndicator.
children notNil ifTrue:[
fetchOperation := nil.
children notEmpty ifTrue:[ self changed:#redraw ].
] ifFalse:[
"/ is a remote or very slow file system
fetchOperation == #hasChildren ifTrue:[
self changed:#redraw
].
].
!
resetFetchIndicator
"update indication cycle has deregistered the item
"
fetchOperation := nil.
! !
!HierarchicalFileList::Directory methodsFor:'queries'!
hasChildren
"returns true if children exists
"
|model|
children notNil ifTrue:[
fetchOperation := nil.
^ children size ~~ 0
].
fetchOperation ifNotNil:[
^ fetchOperation == #hasChildren
].
model := self model.
model notNil ifTrue:[
fetchOperation := #fetching.
model startIndicatorValidationFor:self.
] ifFalse:[
self error:'should not happen' mayProceed:true.
fetchOperation := nil
].
^ children size ~~ 0
!
isDirectory
"always returns true
"
^ true
! !
!HierarchicalFileList::Directory methodsFor:'validation'!
invalidateRepairNow:doRepair
"invalidate contents
"
fetchOperation := modificationTime := nil.
isExpanded ifFalse:[
children := nil
] ifTrue:[
doRepair ifTrue:[
self monitoringCycle
] ifFalse:[
children size == 0 ifTrue:[
"/ expanded but no children added, thus can reset the children
children := nil
]
]
].
!
matchBlockChanged
"called if the matchBlock changed
"
modificationTime := nil.
isExpanded ifFalse:[
fetchOperation := children := nil.
] ifTrue:[
self monitoringCycle.
children size ~~ 0 ifTrue:[
children do:[:aChild| aChild matchBlockChanged ]
]
].
!
monitoringCycle
"run monitoring cycle
!!!!!!!! called by the HierarchicalList only !!!!!!!!
"
|unusedDict addedItems mergedList size modifyTime model timeChanged|
modifyTime := fileName modificationTime.
modifyTime ifNil:[^ self].
timeChanged := (modificationTime isNil or:[modifyTime > modificationTime]).
modificationTime := modifyTime.
children ifNotNil:[
timeChanged ifFalse:[
^ self
].
].
isExpanded ifFalse:[
timeChanged ifTrue:[
fetchOperation := children := nil.
self changed:#redraw.
].
^ self
].
model := self model.
children ifNil:[ children := #() ]. "/ disable update during merge
fetchOperation := nil.
mergedList := model childrenFor:self.
mergedList size == 0 ifTrue:[
self removeAll.
^ self
].
size := children size.
size == 0 ifTrue:[
self addAll:mergedList.
^ self
].
model criticalDo:[
addedItems := OrderedCollection new:128.
unusedDict := Dictionary new:size.
children do:[:el| unusedDict at:(el fileName) put:el ].
mergedList keysAndValuesDo:[:anIndex :anItem| |item|
item := unusedDict removeKey:(anItem fileName) ifAbsent:nil.
item notNil ifTrue:[
mergedList at:anIndex put:item
] ifFalse:[
addedItems add:anItem.
anItem parent:self.
].
].
"/ 12 is hardcoded !!!!!!!!
(unusedDict size + addedItems size) > 12 ifTrue:[
"/ generate two nofifications: collapse and expand
self collapse.
children := mergedList.
self expand.
] ifFalse:[
unusedDict do:[:el| self remove:el ].
addedItems notEmpty ifTrue:[
self addAll:addedItems
].
"/ children order changed test
children := mergedList.
self childrenOrderChanged.
].
].
!
sortBlockChanged
"called if the matchBlock changed
"
modificationTime := nil.
isExpanded ifFalse:[
fetchOperation := children := nil.
] ifTrue:[
self monitoringCycle.
children size ~~ 0 ifTrue:[
children do:[:aChild| aChild sortBlockChanged ]
]
].
! !
!HierarchicalFileList::RemoteDirectory methodsFor:'queries'!
hasChildren
"returns true if children exists
"
children notNil ifTrue:[
fetchOperation := nil.
^ children size ~~ 0
].
fetchOperation := #hasChildren.
^ true
!
isRemoteDirectory
^ true
! !
!HierarchicalFileList class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libwidg2/HierarchicalFileList.st,v 1.30 2002-10-14 12:49:36 penk Exp $'
! !