Object subclass:#DropObject
instanceVariableNames:'theObject'
classVariableNames:''
poolDictionaries:''
category:'Interface-Support'
!
DropObject class instanceVariableNames:'DisplayObject'
"
The following class instance variables are inherited by this class:
Object -
"
!
DropObject subclass:#File
instanceVariableNames:'info isHtmlFile isImageFile isPrintable'
classVariableNames:''
poolDictionaries:''
privateIn:DropObject
!
DropObject subclass:#Color
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:DropObject
!
DropObject subclass:#Image
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:DropObject
!
DropObject subclass:#Text
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:DropObject
!
!DropObject class methodsFor:'instance creation'!
new:someThing
"create an instance dependant on something
"
|cls|
someThing isColor ifTrue:[cls := Color
] ifFalse:[someThing isImageOrForm ifTrue:[cls := Image
] ifFalse:[(someThing isKindOf:Filename) ifTrue:[cls := File
] ifFalse:[cls isString ifTrue:[cls := Text
] ifFalse:[
cls := DropObject
]]]].
^ cls new theObject:someThing
!
newColor:aColor
^ Color new theObject:aColor
!
newFile:aFilename
^ File new theObject:aFilename
!
newImage:anImageOrForm
^ Image new theObject:anImageOrForm
!
newText:aTextOrString
^ Text new theObject:aTextOrString
! !
!DropObject class methodsFor:'defaults'!
displayObject
DisplayObject notNil ifTrue:[
^ DisplayObject
].
DisplayObject := Smalltalk::Image fromFile:(self displayObjectName).
^ DisplayObject
!
displayObjectName
^ 'bitmaps/xpmBitmaps/plain_pixmaps/balloon3.xpm'
! !
!DropObject methodsFor:'accessing'!
theObject
"return the value of the instance variable 'theObject' (automatically generated)"
^ theObject!
theObject:something
"set the value of the instance variable 'theObject' (automatically generated)"
theObject := something.! !
!DropObject methodsFor:'queries'!
displayObject
"return my graphical representation - here a default is returned"
^ self class displayObject
! !
!DropObject methodsFor:'testing'!
isColorObject
^ false
!
isFileObject
^ false
!
isImageObject
^ false
!
isTextObject
^ false
! !
!DropObject::File class methodsFor:'defaults'!
displayObjectName
^ 'bitmaps/xpmBitmaps/plain_pixmaps/xfm_file.xpm'
! !
!DropObject::File methodsFor:'accessing'!
theObject:aPathname
|path|
path := OperatingSystem pathNameOf:(aPathname asString).
info := OperatingSystem infoOf:path.
super theObject:(path asFilename)
! !
!DropObject::File methodsFor:'queries'!
exists
"returns true if file exists
"
^ info notNil
!
isDirectory
"checks whether file is a directory
"
^ (info notNil and:[info type == #directory])
!
isHtmlFile
"checks whether file is a html file
"
|suffixes pathName|
isHtmlFile isNil ifTrue:[
(info isNil or:[self isDirectory]) ifTrue:[
isHtmlFile := false
] ifFalse:[
pathName := theObject asString.
suffixes := #( '.html' '.htm' '.HTML' '.HTM' ).
isHtmlFile := (suffixes findFirst:[:el|pathName endsWith:el]) ~~ 0
]
].
^ isHtmlFile
!
isImageFile
"returns true if file is assigned to an image
"
|suffixes pathName|
isImageFile isNil ifTrue:[
(info isNil or:[self isDirectory]) ifTrue:[
isImageFile := false
] ifFalse:[
pathName := theObject asString.
suffixes := #( '.xpm' '.xbm' '.tiff' '.gif' '.bmp' '.ico' '.icon' ).
isImageFile := (suffixes findFirst:[:el|pathName endsWith:el]) ~~ 0
]
].
^ isImageFile
!
isPrintable
"returns false if file contains non printable characters
"
|stream buff size|
isPrintable isNil ifTrue:[
isPrintable := false.
(info isNil or:[self isDirectory]) ifFalse:[
stream := FileStream readonlyFileNamed:(theObject pathName).
stream isNil ifFalse:[
buff := String new:300.
size := stream nextBytes:300 into:buff.
stream close.
].
1 to:size do:[:i|
(buff at:i) isPrintable ifFalse:[
^ isPrintable
]
].
isPrintable := true
]
].
^ isPrintable
! !
!DropObject::File methodsFor:'testing'!
isFileObject
^ true
! !
!DropObject::Color class methodsFor:'defaults'!
displayObjectName
^ 'bitmaps/xpmBitmaps/plain_pixmaps/paint2.xpm'
! !
!DropObject::Color methodsFor:'testing'!
isColorObject
^ true
! !
!DropObject::Image class methodsFor:'defaults'!
displayObjectName
^ 'bitmaps/xpmBitmaps/plain_pixmaps/hobbes.xpm'
! !
!DropObject::Image methodsFor:'testing'!
isImageObject
^ true
! !
!DropObject::Text class methodsFor:'defaults'!
displayObjectName
^ 'bitmaps/xpmBitmaps/plain_pixmaps/xfm_text.xpm'
! !
!DropObject::Text methodsFor:'testing'!
isTextObject
^ true
! !
!DropObject class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libview2/DropObject.st,v 1.3 1997-02-03 09:12:22 ca Exp $'
! !