'From VisualWorks(R) Release 2.0 of 4 August 1994 on 29 April 1995 at 8:15:04 pm'! !ComposingComposite methodsFor: 'private'! layoutComponentsForBounds: newBounds "The receiver has been sized to the given parameters. Re-layout all of the receiver's components." | offset x top lineHeight itemsOnLine | offset := self leftSpace. offset > newBounds width ifTrue: [offset := 0]. x := offset. top := self extraSpaceTop. lineHeight := 0. itemsOnLine := 0. 1 to: components size do: [ :i | | box component componentHeight itemBox| component := components at: i. itemBox := component preferredBounds. componentHeight := itemBox height. box := x @ top extent: ((itemBox width max: self minimumItemWidth) min: self maximumItemWidth) @ componentHeight. box right > newBounds right ifTrue: ["Item does not fit on this line. Start a new line." x := offset. "reset x" top := top + lineHeight + self extraSpaceBetweenLines. "compute top of next line." itemsOnLine = 0 ifFalse: ["Put this item at the start of the next line." box moveTo: x@top. "move to next line." lineHeight := componentHeight. x := x + self spaceBetweenItems + box width] ifTrue: ["This item does not even fit on an empty line!! Force it." lineHeight := 0]. itemsOnLine := 1] ifFalse: ["Item fits on line. Adjust line height." lineHeight := lineHeight max: componentHeight. itemsOnLine := itemsOnLine + 1. x := x + self spaceBetweenItems + box width]. component bounds: box]. self computePreferredBounds. preferredBounds bottom: preferredBounds bottom + extraSpaceBottom! ! 'Copyright (C) 1994 ParcPlace Systems, Inc. All Rights Reserved.'! ChangeSet current addPatch: 'Socket-VW2.0'! BlockableIOAccessor subclass: #SocketAccessor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OS-Sockets'! SocketAccessor comment: 'UnixSocketAccessor instances correspond to the Unix BSD concept of a "socket", that is, an Inter-Process Communications (IPC) mechanism endpoint. BSD sockets are a protocol-independent *service interface* to multiple IPC/Network implementations. As such, they only refer to abstract facilities that such implementations make concrete. BSD documentation sometimes refers to network implementations as "communications domains" or "protocol families". Every socket is associated with a communications domain and is of some "type" which is one of: stream: provides sequenced, reliable, two-way byte-stream connections with support for out-of-band (OOB) transmission. datagram: provides connectionless, unreliable, fixed-maximum-length messages. raw: provides direct access to network interfaces (for the super-user). sequenced-packet: provides sequenced, reliable, record-oriented connections -- not implemented in most systems. reliably-delivered-message (RDM): reliable datagrams -- not implemented in most systems. A given domain may implement a type with one or more protocols, or not at all. A socket has a "socket address" (which BSD documentation sporadically refers to as "name") the interpretation of which is controlled by the socket''s domain; see the comments in class SocketAddress and its subclasses. Using sockets properly usually involves synchronizing the action of four agents: The server (some user process that provides a service). The client (some user process that requires the service). The server''s network implementation (usually performed by the OS kernel). The client''s network implementation (usually performed by the OS kernel). As such, it usually requires special care by the programmer of the client or server to get things right (can we say that the control flow of the system is four times as complex as it is usually?) Look on the class-side for more documentation and examples. Also see the "Inter-Process Communications Primer" supplied with BSD documentation. '! !SocketAccessor methodsFor: 'instance creation'! accept "Accept a connection (receiver must be stream-based, have already been bound to an address and listening)." "Accept extracts the first connection on the queue of pending connections, and returns a new socketAccessor instance with the same properties as the receiver. It also returns the SocketAddress of the peer (which this code throws away). If there are no outstanding connections, the calling process will block indefinitely." "Wait for pending connection." self readWait. ^self class handleValue: [| a | a := self primAccept. "(a at: 2) contains peer's socket-address -- SocketAddress canonicalize: (a at: 2)." a at: 1]! acceptNonBlock "Accept a connection (receiver must be stream-based, have already been bound to an address and listening)." "Accept extracts the first connection on the queue of pending connections, and returns a new socketAccessor instance with the same properties as the receiver. It also returns the SocketAddress of the peer (which this code throws away). If there are no outstanding connections, returns nil." ^self class handleValue: [| a | a := self errorReporter notReadySignal handle: [:ex | ex restartDo: [^nil]] do: [self primAccept]. "(a at: 2) contains peer's socket-address -- SocketAddress canonicalize: (a at: 2)." a at: 1]! ! !SocketAccessor methodsFor: 'accessing'! bufferSize "Answer the recommended buffer size for this accessor." "sockets are special." ^4096! getName "Return the socket's socket-address, properly canonicalized." ^SocketAddress canonicalize: (self primGetName)! getOptionsLevel: l name: n "Returns a ByteArray containing socket's specified option's value." ^self reportError! getPeer "Return the socket peer's socket-address, properly canonicalized." ^SocketAddress canonicalize: (self primGetPeer)! setOptionsLevel: l name: n value: v "Set the socket's option at level l named n to value v." "v can be a ByteArray, a SmallInteger, or nil." ^self reportError! ! !SocketAccessor methodsFor: 'constants'! connectPauseInterval "Answer an appropriate number of milliseconds to wait for conections." ^20000! lineEndConvention ^IOAccessor defaultLineEndConvention! ! !SocketAccessor methodsFor: 'testing'! atMark "Returns true if socket is at OOB data mark." ^self reportError! ! !SocketAccessor methodsFor: 'specialized IO'! receiveFrom: sa buffer: b "Receive data on a SocketAccessor. Put it into the buffer b (a ByteArray or String) Side-effects SocketAddress sa to contain the peer's address. This is a low-level message which requires external synchronization (e.g. readWait)." ^self receiveFrom: sa buffer: b start: 1 for: b basicSize flags: 0! receiveFrom: sa buffer: b start: s for: c "Receive data on a SocketAccessor. Put it into the buffer b (a ByteArray or String) starting at index s for c bytes. Side-effects SocketAddress sa to contain the peer's address. This is a low-level message which requires external synchronization (e.g. readWait)." ^self receiveFrom: sa buffer: b start: s for: c flags: 0! receiveFrom: sa buffer: b start: s for: c flags: f "Receive data on a SocketAccessor. Put it into the buffer b (a ByteArray or String) starting at index s for c bytes. Flags are the union of the ``msg'' socket options. Side-effects SocketAddress sa to contain the peer's address. This is a low-level message which requires external synchronization (e.g. readWait)." | cnt | cnt := self primReceiveFrom: sa buffer: b start: s for: c flags: f. sa canonicalize. ^cnt! sendTo: sa buffer: b "Transmits the message in buffer b (a ByteArray or String) through the SocketAccessor destined for the peer at SocketAddress sa. This is a low-level message which requires external synchronization (e.g. writeWait)." ^self sendTo: sa buffer: b start: 1 for: b basicSize flags: 0! sendTo: sa buffer: b start: s for: c "Transmits the message in buffer b (a ByteArray or String) starting at index s for c bytes through the SocketAccessor destined for the peer at SocketAddress sa. This is a low-level message which requires external synchronization (e.g. writeWait)." ^self sendTo: sa buffer: b start: s for: c flags: 0! sendTo: sa buffer: b start: s for: c flags: f "Transmits the message in buffer b (a ByteArray or String) starting at index s for c bytes through the SocketAccessor destined for the peer at SocketAddress sa. The flags f is a SmallInteger which is the union of the socket ``msg'' options. This is a low-level message which requires external synchronization (e.g. writeWait)." ^self reportError! shutdown: num "Inform the socket accessor that no more IO will be performed: 0 -- read only, 1 -- write only, 2 -- both" "shutdown: 2 is more dramatic (and faster) than close since it discards any pending data." ^self reportError! ! !SocketAccessor methodsFor: 'state transitions'! bindTo: aSocketAddress "Bind an address to an unaddressed socket." "Note -- bindTo: specifies the address which identifies the local address of the connection, connectTo: specifies the address which identifies the remote address of the connection." "returns self" ^self reportError! connectTo: aSocketAddress "If this is a datagram-type socket, permanently specify the peer to which datagrams will be sent. If this is a stream-type socket, attempts to make the connection. Waits until the connection is established." "Note -- connectTo: specifies the address which identifies the remote address of the connection, bindTo: specifies the address which identifies the local address of the connection." "We must catch both operationStartedSignal and notReadySignal because Unixes differ in what error code they return for a pending socket connection." (SignalCollection with: self errorReporter operationStartedSignal with: self errorReporter notReadySignal) handle: [:ex | ex restartDo: [self waitForConnection]] do: [self primConnectTo: aSocketAddress]! listenFor: aSmallInteger "Permit the acception of connections, argument specifies maximum connection queue backlog." "returns self" ^self reportError! ! !SocketAccessor methodsFor: 'private'! primClose "Close the accessor." self reportErrorProceeding! primNofailReadInto: buffer startingAt: index for: count "buffer is a byte-object, the place where IO is performed. index is a SmallInteger, the starting-point in the buffer. count is a SmallInteger, the number of bytes to be read." "Returns a SmallInteger, which is the count of the bytes read." "WouldBlock is a potential error condition." ^nil! primNofailWriteFrom: buffer startingAt: index for: count "buffer is a byte-object, the place where IO is performed. index is a SmallInteger, the starting-point in the buffer. count is a SmallInteger, the number of bytes to be written." "Returns a SmallInteger, which is the count of the bytes written." ^nil! primReadInto: buffer startingAt: index for: count "buffer is a byte-object, the place where IO is performed. index is a SmallInteger, the starting-point in the buffer. count is a SmallInteger, the number of bytes to be read." "Returns a SmallInteger, which is the count of the bytes read." "WouldBlock is a potential error condition." (self class restartableError: errorCode) ifTrue: [self readWait. ^self primReadInto: buffer startingAt: index for: count]. ^self reportErrorProceeding! primWriteFrom: buffer startingAt: index for: count "buffer is a byte-object, the place where IO is performed. index is a SmallInteger, the starting-point in the buffer. count is a SmallInteger, the number of bytes to be written." "Returns a SmallInteger, which is the count of the bytes written." "WouldBlock is a potential error condition." (self class restartableError: errorCode) ifTrue: [self writeWait. ^self primWriteFrom: buffer startingAt: index for: count]. ^self reportErrorProceeding! primAccept "Accept a connection (receiver must be stream-based, have already been bound to an address and listening). Accept extracts the first connection on the queue of pending connections, and returns a new socket with the same properties as the receiver. If there are no outstanding connections, the socket will get a wouldBlock error." "returns an Array with: sockSmallInteger with: aSocketAddress" ^self reportError! setSem: sem forWrite: bool "Signal this semaphore when the fd is ready for an IO operation. bool is true if the fd is for writing, false if for reading." ^self reportError! primConnectTo: aSocketAddress "If this is a datagram-type socket, permanently specify the peer to which datagrams will be sent. If this is a stream-type socket, attempts to make the connection." "Note -- connectTo: specifies the address which identifies the remote address of the connection, bindTo: specifies the address which identifies the local address of the connection. You're very likely to get an inProgress or wouldBlock error, which means you should (write) wait before doing anything else." "Returns self." ^self reportError! primGetName "returns SocketAddress" ^self reportError! primGetPeer "returns SocketAddress" ^self reportError! primReceiveFrom: sa buffer: b start: s for: c flags: f "Receive data on a SocketAccessor. Put it into the buffer b (a ByteArray or String) starting at index s for c bytes. Flags are the union of the ``msg'' socket options. Side-effects SocketAddress sa to contain the peer's address, which is not canonicalized. This is a low-level message which requires external synchronization (e.g. readWait)." ^self reportError! waitForConnection "Wait until I have been connected to my peer; answer the peer's address." "Because of subtle OS differences w.r.t. how to wait on a pending connection, we wait until the peer address is available; the polling heuristic is to wait for any activity (or a timeout)." | sem dly readReady writeReady rSigError wSigError peer errorSignal timeout | errorSignal := self errorReporter errorSignal. dly := Delay forMilliseconds: self readPauseInterval. sem := dly delaySemaphore. readReady := writeReady := false. rSigError := wSigError := false. "start an overall connection timeout delay" timeout := Delay forMilliseconds: self connectPauseInterval. timeout startup. [peer := errorSignal handle: [:ex | ex returnWith: nil] do: [self getPeer]. peer isNil and: [timeout inProgress]] whileTrue: [sem initSignals. readReady := errorSignal handle: [:ex | rSigError := true. ex returnWith: false] do: [rSigError := false. self setSem: sem forWrite: false]. writeReady := errorSignal handle: [:ex | wSigError := true. ex returnWith: false] do: [wSigError := false. self setSem: sem forWrite: true]. readReady | writeReady ifFalse: ["Wait for data arrival or timeout expiry." dly disable. dly startup. sem wait]]. "remove all the semaphores" dly disable. errorSignal handle: [:ex | ex return] do: [readReady not & rSigError not ifTrue: [self setSem: nil forWrite: false]. writeReady not & wSigError not ifTrue: [self setSem: nil forWrite: true]]. peer isNil ifTrue: [^self errorReporter peerFaultSignal raiseFrom: self]. ^peer! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SocketAccessor class instanceVariableNames: ''! !SocketAccessor class methodsFor: 'class initialize/release'! initialize "Initialize and install the class if appropriate." "SocketAccessor initialize" self install. (ClassesRequiringInstallation includes: self) ifFalse: [ClassesRequiringInstallation add: self].! install "Tell the VM to do any needed initialization." self primInit: (Array with: SocketAddress)! obsolete "Part of removing the class from the system" super obsolete. ClassesRequiringInstallation remove: self ifAbsent: []! ! !SocketAccessor class methodsFor: 'instance creation'! family: fSmInt type: tSmInt "Return a new SocketAccessor in the specified domain (family) and type, using the default protocol." ^self handleValue: [self primFamily: fSmInt type: tSmInt protocol: self pfUnspec errInto: self errorReporter new]! family: fSmInt type: tSmInt protocol: pSmInt "Return a new SocketAccessor in the specified domain (family) type and protocol." ^self handleValue: [self primFamily: fSmInt type: tSmInt protocol: pSmInt errInto: self errorReporter new]! newTCP "Appropriate for clients, or for servers with no assigned ports." | skt sa | skt := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockStream. [sa := IPSocketAddress thisHostAnyPort. skt bindTo: sa] valueOnUnwindDo: [skt close]. ^skt! newTCPclientToHost: hname port: pnum "Create a client socket connected to host hname/port pnum" | skt fa | skt := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockStream. [fa := IPSocketAddress hostName: hname port: pnum. skt connectTo: fa] valueOnUnwindDo: [skt close]. ^skt! newTCPserverAtPort: pnum "Create an instance prepared to be a TCP server at the specified port." | skt sa | skt := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockStream. [sa := IPSocketAddress hostAddress: IPSocketAddress thisHost port: pnum. skt bindTo: sa] valueOnUnwindDo: [skt close]. ^skt! newUDP "Appropriate for clients or for servers with no preassigned ports." | skt sa | skt := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockDgram. [sa := IPSocketAddress thisHostAnyPort. skt bindTo: sa] valueOnUnwindDo: [skt close]. ^skt! newUDPserverAtPort: pnum "Create an instance prepared to be a UDP server at the specified port." | skt sa | skt := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockDgram. [sa := IPSocketAddress hostAddress: IPSocketAddress thisHost port: pnum. skt bindTo: sa] valueOnUnwindDo: [skt close]. ^skt! openPair "Make a pair of connected sockets. Returns an (Array with: fd1 with: fd2)." "Deal with losing socket implementations which don't implement socketpair(2)." ^self unsupportedOperationSignal handle: [:ex | ex returnWith: (self phonyPair)] do: [self registerAllValuesOf: [| fd2 | fd2 := self primPairErrorInto: self errorReporter new. Array with: (self handleNoRegister: (fd2 at: 1)) with: (self handleNoRegister: (fd2 at: 2))]]! phonyPair "Simulates the action of openPair, but using the IP domain. Returns Array with: IOAccessor with: IOAccessor" "This is just here in order to deal with losing socket implementations which don't implement socketpair and who don't do Unix-domain rendesvous correctly." | s1 s2 s3 sa sb | s1 := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockStream. s2 := self family: (SocketAddress domainCodeFromName: #afInet) type: self sockStream. [sa := IPSocketAddress thisHostAnyPort. s1 bindTo: sa. "Use loopback interface." sb := (s1 getName) hostName: 'localhost'. s1 listenFor: 1. s2 connectTo: sb. s3 := s1 accept] valueOnUnwindDo: [s1 close. s2 close]. s1 close. ^Array with: s3 with: s2! ! !SocketAccessor class methodsFor: 'accessing'! defaultClass "Answer the appropriate concrete subclass." ^self! getHostname "Answer a string with the current platform's host name." ^self primitiveFailed! ! !SocketAccessor class methodsFor: 'constants-socket options'! msgDontroute "Socket send option flag to send without using routing tables." ^4! msgOob "Socket send/recieve option flag to process out-of-band data." ^1! msgPeek "Socket receive option flag to peek at incoming message." ^2! soAcceptconn "Socket option for expressing willingness to accept connections." ^2! soDebug "Socket option constant for turning on debug info recording." ^1! soDontlinger "Socket option constant to not linger on close (even if data present)." ^self soLinger bitInvert! soDontroute "Socket option constant for direct use of interface addresses." ^16r10! soKeepalive "Socket option constant allowing keep connections alive." ^8! soLinger "Socket option constant to linger on close if data present." ^16r80! solSocket "Level number for get/setOptions to apply to socket itself." ^16rFFFF! soReuseaddr "Socket option constant allowing local address reuse." ^4! soUseloopback "Socket option constant to bypass hardware when possible." ^16r40! ! !SocketAccessor class methodsFor: 'constants-socket types'! sockDgram "Constant for socket type providing connectionless, unreliable, fixed-maximum-length messages." ^2! sockRaw "Constant for socket type indicating direct access to network interfaces. Only accessable to privileged users." ^3! sockRdm "Constant for socket type providing reliable datagrams -- not implemented in most systems." ^4! sockSeqpacket "Constant for socket type providing sequenced, reliable, record-oriented connections -- not implemented in most systems." ^5! sockStream "Constant for socket type providing sequenced, reliable, two-way byte-stream connections with support for out-of-band (OOB) transmission." ^1! ! !SocketAccessor class methodsFor: 'constants-protocol families'! pfInet "Answer protocol family code for Internet protocols." ^2! pfUnix "Answer protocol family code for Unix-domain ``protocols''." ^1! pfUnspec "Answer protocol family code for unspecified protocols." ^0! ! !SocketAccessor class methodsFor: 'documentation'! howToImplementAClient "If you want to implement a client for some (connection-based) service which already exists, you may want to read this. We'll assume the service is IP/TCP based. First you need to create the socket and connect it to the server. Let's assume you know the host name, 'servicehost' and you know the port number is 175. In that case: skt := SocketAccessor newTCPclientToHost: 'servicehost' port: 175. At this point, the SocketAccessor can be read and written to just like a DiskFileAccessor (e.g. you can use readInto:starting... and writeFrom:starting... and readWait and writeWait, etc). For streaming, you can create a connection, and then ask the connection for a stream: conn := ExternalStream new input: skt; output: skt. stream := conn readStream. When you're done communicating with the service, just: skt close. finishes the job. stream close will close the socket as well, so both are not necessary" ^self error: 'comment only'! howToImplementAServer "If you want to implement a server for some (connection-based) service you may want to read this. We'll assume the service is to be IP/TCP based. First, you create a socket and bind the socket to an address. A more complicated issue is what port number you should assign your service. This issue is discussed in the documentation for class IPSocketAddress -- for this example, we'll assume you've already arranged for your service to be at port 175. So: skt := SocketAccessor newTCPserverAtPort: 175. ...now you've published a socket for your host at port 175, but you need to accept the connections which will be arriving. First, you inform the OS to construct a connection queue of some maximum length (5 is the longest queue most implementations will allow). Let's say that you're only willing to handle two clients at a time: skt listenFor: 2. ...now you can accept arriving connections: newskt := skt accept. ...newskt is a new SocketAccessor of an ''equivalent'' domain, type and protocol to the original socket. The port number is (I think) an arbitrary one assigned by the system. If you wish, you can send getPeer to the newskt first, to validate that your client is originating on a system you are willing to provide services to (if not, you should send close to newskt and start over). At this point you probably want to fork off a process to provide the service, while the original process waits for the next connection with accept. The forked process which actually provides the service will have newskt, a SocketAccessor which can be read and written to just like a DiskFileAccessor (e.g. you can use readInto:starting... and writeFrom:starting... and readWait and writeWait, etc). When you're done providing the service to a given client, your forked process should just send: newskt close. and terminate itself. When you are no longer willing to accept new connections from clients you just send: skt close Streams can be used on newskt in the same fashion as for client sockets" ^self error: 'comment only'! howToUseDatagramSockets "Connectionless IPC (using datagram sockets) is quite different from connection-oriented IPC. Typically, each transaction is of a known length, and each transation may be associated with a different peer. Datagrams are supported for both the Unix and Internet domains. We'll use Unix-domain for this example, one where both peers are symmetric. First, you construct a socket of the appropriate type: skt := SocketAccessor family: (SocketAddress domainCodeFromName: #afUnix) type: (SocketAccessor sockDgram) protocol: (SocketAccessor pfUnspec). ...and then one side would bind to an address: mySa := UDSocketAddress name: '/tmp/foo'. skt bindTo: mySa. ...and perhaps set-up to home to a particular peer: hisSa := UDSocketAddress name: '/tmp/bar'. skt connectTo: hisSa. ...the peer would swap the addresses but execute similar code. At this point, both sides could use their sockets for normal reading and writing, if the transaction sizes were known in advance. If the application were more client/server style, the server would forgo the connectTo: (since he wouldn't know who the client was in advance. The client would skip the bindTo:, and let the system assign a socket address for him. The server would communicate to his client(s) by reading with receiveFrom:buffer..., and using the socket address returned, reply to a given client using sendTo:buffer:... The clients could use normal read/write protocol." ^self error: 'comment only'! ! !SocketAccessor class methodsFor: 'examples'! exampleIPClient "This example creates a simple TCP client that sends a single message and waits for a reply. Use 'print it' on this example, but first start the server (see exampleIPServer)." "SocketAccessor exampleIPClient" | host port socket connection stream reply | "The server prints the hostname and port number in the Transcript -- prompt the user for that info." host := Dialog request: 'What is the name of the server''s host?' initialAnswer: 'localhost'. port := (Dialog request: 'What is the server''s port number?' initialAnswer: '') asNumber. "Create a socket on the given host and port." socket := self newTCPclientToHost: host port: port. "Open a two-way connection on the socket." connection := ExternalConnection new. connection input: socket; output: socket. "Open a stream on the socket connection." stream := connection readAppendStream. "Since the server and client might be on different operating systems, choose a neutral line end convention." stream lineEndTransparent. "Send a message to the server, then get the reply." stream nextPutAll: 'Hello from the client!!'; cr; commit. reply := stream through: Character cr. "Close the stream (which closes the socket)." stream close. ^reply! exampleIPServer "This example creates a simple TCP server that waits for a single message and sends a reply. Start the server (by executing the following comment), then run exampleIPClient." "[SocketAccessor exampleIPServer] forkAt: Processor userInterruptPriority" | socket childSocket counter connection stream | "Create a socket, then show its name in the Transcript." socket := self newTCP. Transcript beginEntry; cr; nextPutAll: 'Bound server socket to: '. Transcript cr; tab; print: socket getName; cr; endEntry. "Set up a queue for a single connection." socket listenFor: 1. "Look for a client 50 times, waiting 5 seconds between attempts." childSocket := nil. counter := 50. [childSocket isNil and: [counter > 0]] whileTrue: [ Transcript nextPutAll: 'Waiting for connection...'. counter := counter - 1. (Delay forSeconds: 5) wait. childSocket := socket acceptNonBlock. Transcript cr; endEntry]. "If no client solicited a connection, give up." childSocket isNil ifTrue: [ Transcript show: 'Giving up!!'; cr. socket close. ^self]. "A client did inquire -- set up a stream on a two-way connection." connection := ExternalConnection new input: childSocket; output: childSocket. stream := connection readAppendStream. "Since the server and client might be on different operating systems, choose a neutral line end convention." stream lineEndTransparent. "Display the client's message, then send a response." Transcript nextPutAll: (stream through: Character cr); cr; endEntry. stream nextPutAll: 'Hello from the server!!'; cr. "Close the stream (which closes childSocket) and the parent socket." stream close. socket close! exampleTalkClient "This example creates a simple UDP client that sends single packets to a talk server and displays the acknowledgment. It could be used as the basis for a 'talk' client. Before executing this example, start the server (see exampleTalkServer)." "SocketAccessor exampleTalkClient" | socket address buffer host msg | "Get the host name from the user." host := Dialog request: 'What is the name of the server''s host?' initialAnswer: 'localhost'. "Create a datagram socket." socket := self newUDP. "Bind the socket to an address, using an obscure port." address := IPSocketAddress hostName: host port: 6666. "Prompt for a message, repeating until the dialog is left blank. The server returns the message as acknowledgment -- display it." buffer := String new: 1000. [[(msg := Dialog request: 'Say something') isEmpty] whileFalse: [ | replySize | socket writeWait. socket sendTo: address buffer: msg. socket readWait. replySize := socket receiveFrom: address buffer: buffer. replySize > 0 ifTrue: [ Transcript cr; nextPutAll: 'Server acknowledged: '. Transcript show: (buffer copyFrom: 1 to: replySize)]]] valueNowOrOnUnwindDo: [socket close]. Transcript cr! exampleTalkServer "This example creates a simple UDP server that accepts single packets from anybody and broadcasts them to all clients that have connected so far. It could be used as the basis for a 'talk' server. Start the server (by executing the following comment), then run exampleTalkClient. To stop the server, press the button on the mouse." "[SocketAccessor exampleTalkServer] forkAt: Processor userInterruptPriority" | socket address buffer msgSize clients | clients := Set new. address := IPSocketAddress new. buffer := String new: 1024. "Create a socket on the port server's port." socket := self newUDPserverAtPort: 6666. "Announce the server's availability." Transcript cr; show: 'Talk server starting'. "Wait for data until button is pressed or timeout." [[InputState default mouseButtons = 4] whileFalse: [ (socket readWaitWithTimeoutMs: 200) ifFalse: [ "Get the next message and store its length." msgSize := socket receiveFrom: address buffer: buffer start: 1 for: buffer size. "Add the client to the set of broadcast receivers." clients add: address copy. "Broadcast the packet to each client." clients do: [ :clientAddress | socket sendTo: clientAddress buffer: buffer start: 1 for: msgSize]]]] valueNowOrOnUnwindDo: [Transcript cr; show: 'Talk server shutting down'. socket close]! requestTimeService "This example uses the IP/UDP time service, which returns the time in seconds since Jan 1, 1900 as a four-byte integer. Thus, we are demonstrating raw access through a socket instead of using an external stream. We explicitly convert the raw result and print it in the transcript. We assume that a time server is running on the host that you name." "SocketAccessor requestTimeService" | socket address buffer replySize host time | "Get the host name from the user." host := Dialog request: 'Which host is running a time server?' initialAnswer: 'localhost'. "Create a datagram socket." socket := self newUDP. "The following is kept in an unwind block in case an exception is raised." [ "Bind the socket to the server's address." address := IPSocketAddress hostName: host port: (IPSocketAddress servicePortByName: 'time'). socket connectTo: address. "Any message will trigger the time server." socket writeAll: 'What time is it?'. "Initialize the buffer for a four-byte response." buffer := ByteArray new: 4. "Get the raw time from the server -- timeout after 10 seconds." (socket readWaitWithTimeoutMs: 10000) ifFalse: [replySize := socket readInto: buffer] ifTrue: [Transcript cr; nextPutAll: 'No reply'] ] valueNowOrOnUnwindDo: [socket close]. replySize = 4 "If four bytes were returned, convert to time and display it." ifTrue: [ "Convert the byte array to an integer (seconds since 1900)." time := (UninterpretedBytes from: buffer) unsignedLongAt: 1 bigEndian: true. "Convert the integer to time. Subtract one year (Smalltalk time begins in 1901)." time := Time aTimeString: time - (60*60*24*365). "Display the time." Transcript cr; nextPutAll: 'The server''s clock says: ', time] "If four bytes were not returned, it's either nothing (zero) or invalid." ifFalse: [ replySize = 0 ifTrue: [Transcript cr; nextPutAll: 'No response'] ifFalse: [Transcript cr; nextPutAll: 'Invalid reply format']]. Transcript endEntry! ! !SocketAccessor class methodsFor: 'private-primitives'! primFamily: fSmallInteger type: tSmallInteger protocol: pSmallInteger errInto: anErrorHolder "returns a SmallInteger for the socket fd." ^anErrorHolder reportFor: self! primInit: anArray "Tell the VM to set up for sockets, special classes are supplied in anArray." "Do nothing. This platform has no sockets." ^self! primPairErrorInto: errorHolder "Makes a pair of connected sockets. Returns an (Array with: fd1 with: fd2)." ^errorHolder reportFor: self! ! UninterpretedBytes variableByteSubclass: #SocketAddress instanceVariableNames: '' classVariableNames: 'DomainCodes KnownDomains ' poolDictionaries: '' category: 'OS-Sockets'! SocketAddress comment: 'Instances of this class (and its subclasses) correspond to the BSD socket mechanism''s C-struct "sockaddr". struct sockaddr { u_short sa_family; /* address family */ char sa_data[14]; /* up to 14 bytes of direct address */ }; The first two bytes are the "address family" type identifier. The remaining bytes (maximum of 14) are interpreted by the subclasses. We simply represent all 16 bytes as byte variable data in each instance. We "canonicalize" instances of SocketAddress wherever possible by become-ing them into instances of an appropriate subclass. Only two subclasses have been defined at this time (the ''''known domains''''): IPSocketAddress for the Internet Protocols (IP) domain UDSocketAddress for the Unix Domain see the comments for those classes. Other subclasses can be defined as needed. To do this, you should define a subclass that has appropriate protocol for interpreting the remaining bytes and then add those class names to KnownDomains by editing initKnown; this way, canonicalization can work for the new subclass. Class variables: DomainCodes containing the mapping between address-family codes and a name (Symbol). KnownDomains containing the mapping between address-family name and the appropriate SocketAddress subclass. '! !SocketAddress methodsFor: 'private-accessing'! domainCode: fc "Assign the domain code, canonicalizing if neccessary (may do a become)." self unsignedShortAt: 1 put: fc. self canonicalize! ! !SocketAddress methodsFor: 'byte order reversal'! reverseByteOrder "Reverse the byte order for dealing with platform switch on snapshot return." "Only the domain-code needs reversing, the rest of the bytes are in NBO." | t | t := self byteAt: 1. self byteAt: 1 put: (self byteAt: 2). self byteAt: 2 put: t! ! !SocketAddress methodsFor: 'accessing'! domainCode "Answer the domain code." ^self unsignedShortAt: 1! ! !SocketAddress methodsFor: 'printing'! printBytesOn: aStream "Output the printable representation of the address to the stream." 3 to: self sizeInBytes do: [:i | (self byteAt: i) printOn: aStream. i = self sizeInBytes ifFalse: [aStream nextPut: $.]]! printOn: aStream "Append to the argument, aStream, the printable representation of the domain code and the remaining bytes." | fn fc | aStream print: self class. aStream nextPut: $(. self class = SocketAddress ifTrue: [fc := self domainCode. fn := DomainCodes at: fc ifAbsent: ['af' , fc printString]. aStream nextPutAll: fn asString. aStream space]. self printBytesOn: aStream. aStream nextPut: $)! ! !SocketAddress methodsFor: 'copying'! canonicalize "Convert this instance to a more appropriate class (if needed) by becoming." | newself | newself := self class canonicalize: self. "Avoid unneeded becomes." self = newself ifFalse: [self become: newself]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SocketAddress class instanceVariableNames: ''! !SocketAddress class methodsFor: 'class accessing'! domainCodeFromName: sym "Answer the domain code corresponding to the name (a Symbol)." ^DomainCodes keyAtValue: sym! domainNameFromCode: code "Given the domain code, answer the name (a Symbol)." ^DomainCodes at: code! knownClassFromCode: code "Given a domain code, answer the appropriate concrete class." ^Smalltalk at: (KnownDomains at: (DomainCodes at: code ifAbsent: [#afUnspec]) ifAbsent: [#SocketAddress])! ! !SocketAddress class methodsFor: 'private-copying'! from: sktAddr "Make a new instance by copying the SocketAddress argument." | sz | sz := sktAddr sizeInBytes. ^(self new: sz) replaceBytesFrom: 1 to: sz with: sktAddr startingAt: 1! ! !SocketAddress class methodsFor: 'instance creation'! canonicalize: sa "Given a SocketAddress, return an instance which is of the most appropriate concrete class." | cls | cls := self knownClassFromCode: sa domainCode. sa class = cls ifTrue: [^sa]. ^cls from: sa! new "Return a new instance of the default size and of unspecified type." ^self new: 16! ! !SocketAddress class methodsFor: 'class initialization'! initCodes "Set up the dictionary which maps domain codes to names." "WARNING: HP-UX has different numbers for domain codes greater than 11" DomainCodes := IdentityDictionary new: 17. DomainCodes at: 0 put: #afUnspec. DomainCodes at: 1 put: #afUnix. DomainCodes at: 2 put: #afInet. DomainCodes at: 3 put: #afImplink. DomainCodes at: 4 put: #afPup. DomainCodes at: 5 put: #afChaos. DomainCodes at: 6 put: #afNs. DomainCodes at: 7 put: #afNbs. DomainCodes at: 8 put: #afEcma. DomainCodes at: 9 put: #afDatakit. DomainCodes at: 10 put: #afCcitt. DomainCodes at: 11 put: #afSna. DomainCodes at: 12 put: #afDecnet. DomainCodes at: 13 put: #afDli. DomainCodes at: 14 put: #afLat. DomainCodes at: 15 put: #afHylink. DomainCodes at: 16 put: #afAppletalk.! initialize "SocketAddress initialize." self initCodes. self initKnown! initKnown "Build the dictionary of known specializations of socket addresses." "We use symbols (rather than classes) as values to avoid file-in problems." KnownDomains := IdentityDictionary new: 3. KnownDomains at: #afUnspec put: #SocketAddress. KnownDomains at: #afUnix put: #UDSocketAddress. KnownDomains at: #afInet put: #IPSocketAddress! ! SocketAddress variableByteSubclass: #UDSocketAddress instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OS-Sockets'! UDSocketAddress comment: 'Instances of this class represent socket addresses interpreted in the "Unix Domain" address family. From /usr/include/sys/un.h: struct sockaddr_un { short sun_family; /* AF_UNIX */ char sun_path[109]; /* path name (gag) */ }; The path-name field represents has syntax like ordinary Unix path names. That is, ''/tmp/foo'' is a perfectly reasonable one, but even better would be one that is guaranteed not to collide (maybe use your pid?) A nasty side effect of using Unix-domain sockets is that you have to unlink the path name when you''re done (if you don''t want it hanging around). '! !UDSocketAddress methodsFor: 'accessing'! name "Answer the name as a String." ^self stringAt: 3! name: str "Assign the name." "Names that are too long are silently truncated." "Avoid unneeded becomes." str = self name ifFalse: [self become: (self class name: str)]! ! !UDSocketAddress methodsFor: 'printing'! printBytesOn: aStream "Output the printable representation of the address to the stream." self name printOn: aStream! ! !UDSocketAddress methodsFor: 'private-accessing'! nameLength "Answer the length of the name." 3 to: self sizeInBytes do: [:i | 0 = (self byteAt: i) ifTrue: [^i - 3]]. ^self sizeInBytes - 2! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UDSocketAddress class instanceVariableNames: ''! !UDSocketAddress class methodsFor: 'instance creation'! name: str "Answer a new instance with the supplied name." "Names that are too long are silently truncated." | len n nameStr | nameStr := str class == String defaultPlatformClass ifTrue: [str] ifFalse: [String defaultPlatformClass fromString: str]. nameStr size >= self maxNameLength ifTrue: [nameStr := nameStr copyFrom: 1 to: self maxNameLength-1]. len := nameStr size + 1. n := self new: len + 2. n stringAt: 3 put: nameStr. ^n! new: cnt "Answer a new instance with an uninitialized name." ^(super new: cnt) domainCode: 1.! ! !UDSocketAddress class methodsFor: 'constants'! maxNameLength "Answer the maximum length of the name field." "As the comment in the header file says: (gag)" ^109! ! SocketAddress variableByteSubclass: #IPSocketAddress instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OS-Sockets'! IPSocketAddress comment: 'Instances of this class represent socket addresses interpreted in the ''''Internet (e.g. ARPA) Domain'''' address family. From /usr/include/netinet/in.h: struct in_addr { union { struct { u_char s_b1,s_b2,s_b3,s_b4; } S_un_b; struct { u_short s_w1,s_w2; } S_un_w; u_long S_addr; } S_un; struct sockaddr_in { short sin_family; u_short sin_port; struct in_addr sin_addr; char sin_zero[8]; }; That is, an Internet address has a 2-byte port number and a 4-byte host address. Look for more information about structure of and symbolic names for host addresses and ports in this class''s "documentation" protocol. '! !IPSocketAddress methodsFor: 'printing'! printBytesOn: aStream "Output the printable representation of the address to the stream." aStream nextPutAll: 'port#'; print: self port; space; nextPutAll: 'at:'. aStream nextPutAll: self hostName.! ! !IPSocketAddress methodsFor: 'accessing'! hostAddress "Answer the host address." ^(ByteArray new: 4) replaceBytesFrom: 1 to: 4 with: self startingAt: 5! hostAddress: hba "Assign the host address." self replaceBytesFrom: 5 to: 8 with: hba startingAt: 1! hostName "Answer the host name." | hn | hn := self class hostNameByAddress: self hostAddress. hn isNil ifTrue: [| ws | ws := WriteStream new: 7. 5 to: 8 do: [:i | (self byteAt: i) printOn: ws. i = self sizeInBytes ifFalse: [ws nextPut: $.]]. hn := ws contents]. ^hn! hostName: hn "Assign the host name." | hba | hba := self class hostAddressByName: hn. hba isNil ifTrue: [hn error: 'No such hostname'] ifFalse: [^self hostAddress: hba]! port "Answer the port number." "Network byte order is fixed." ^self unsignedShortAt: 3 bigEndian: true! port: p "Assign the port number (ByteArray or Integer)." "Network byte order is fixed." (p isKindOf: ByteArray) ifTrue: [self byteAt: 3 put: (p at: p size - 1). self byteAt: 4 put: (p at: p size)] ifFalse: ["Assume Integer" self unsignedShortAt: 3 put: p bigEndian: true]! ! !IPSocketAddress methodsFor: 'network addresses'! networkAddress "Answer the network address." "Extract it from the host address." 0 = ((self byteAt: 5) bitAnd: 16r80) ifTrue: [^ByteArray with: (self byteAt: 5)]. 16r80 = ((self byteAt: 5) bitAnd: 16rC0) ifTrue: [^ByteArray with: (self byteAt: 5) with: (self byteAt: 6)]. 16rC0 = ((self byteAt: 5) bitAnd: 16rC0) ifTrue: [^ByteArray with: (self byteAt: 5) with: (self byteAt: 6) with: (self byteAt: 7)]. self error: 'unknown network class'! networkClass "Answer the network class as a symbol (one of #classA #classB #classC)." "Extract it from the host address." 0 = ((self byteAt: 5) bitAnd: 16r80) ifTrue: [^#classA]. 16r80 = ((self byteAt: 5) bitAnd: 16rC0) ifTrue: [^#classB]. 16rC0 = ((self byteAt: 5) bitAnd: 16rC0) ifTrue: [^#classC]. ^self error: 'unknown network class'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IPSocketAddress class instanceVariableNames: ''! !IPSocketAddress class methodsFor: 'instance creation'! hostAddress: ha "Answer a new instance with the given host address." ^self new hostAddress: ha! hostAddress: hn port: p "Answer a new instance with the given host address and port." ^(self new hostAddress: hn) port: p! hostName: hn "Answer a new instance with the given host name." ^self new hostName: hn! hostName: hn port: p "Answer a new instance with the given host name and port." ^(self new hostName: hn) port: p! thisHostAnyPort "Answer an instance which addresses this host through a system-assigned port." ^self hostAddress: self thisHost port: self anyPort! ! !IPSocketAddress class methodsFor: 'private'! allZeros: aByteArray "Answer true if the indexed fields are all 0." aByteArray do: [:e | 0 = e ifFalse: [^false]]. ^true! bytesToName: aByteArray "Convert the bytes to the canonical printed representation." | ws | ws := WriteStream on: (String new: 7). 1 to: aByteArray size do: [:i | (aByteArray at: i) printOn: ws. i = aByteArray size ifFalse: [ws nextPut: $.]]. ^ws contents! new: cnt "Create an new instance." ^(super new: cnt) domainCode: 2.! primHostAddressByName: aString "returns a ByteArray which is the IP address of the named host." err isError ifTrue: [err name = #'bad argument' ifTrue: [aString class == String defaultPlatformClass ifTrue: [^OSErrorHolder badArgumentsSignal raise] ifFalse: [^self primHostAddressByName: (String defaultPlatformClass fromString: aString)]]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self primHostAddressByName: aString]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aString]. ^OSErrorHolder errorSignal raise]. ^OSErrorHolder unsupportedOperationSignal raise! primHostNameByAddress: aByteArray "returns a String which is the host name for the given IP address." err isError ifTrue: [err name = #'bad argument' ifFalse: [^OSErrorHolder badArgumentsSignal raise]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self primHostNameByAddress: aByteArray]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aByteArray]. ^OSErrorHolder errorSignal raise]. OSErrorHolder unsupportedOperationSignal raise! stringToBytes: aString "Convert the string in canonical address format to a byte array." | ba rs fpi st i | ba := ByteArray new: 4. st := 1. i := 1. [st <= aString size] whileTrue: [fpi := aString indexOfSubCollection: '.' startingAt: st ifAbsent: [aString size + 1]. rs := ReadStream on: aString from: st to: fpi - 1. ba at: i put: (Integer readFrom: rs). i := i + 1. st := fpi + 1]. ^ba! ! !IPSocketAddress class methodsFor: 'naming utilities'! hostAddressByName: aString "Answer the host address for the named host." aString = '-thishost-' ifTrue: [^self thisHost]. (aString at: 1) isDigit ifTrue: [^self stringToBytes: aString]. ^self primHostAddressByName: aString! hostNameByAddress: aByteArray "returns a String which is the host name for the given IP address, all zeros means thisHost." | nm | (self allZeros: aByteArray) ifTrue: [^'-thishost-']. nm := self primHostNameByAddress: aByteArray. nm isNil ifTrue: [nm := self bytesToName: aByteArray]. ^nm! netAddressByName: aString "returns a ByteArray which is the IP address of the named network." err isError ifTrue: [err name = #'bad argument' ifTrue: [aString class == String defaultPlatformClass ifTrue: [^OSErrorHolder badArgumentsSignal raise] ifFalse: [^self netAddressByName: (String defaultPlatformClass fromString: aString)]]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self netAddressByName: aString]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aString]. ^OSErrorHolder errorSignal raise]. ^OSErrorHolder unsupportedOperationSignal raise! netNameByAddress: aByteArray "returns a String which is the network name for the given IP address." err isError ifTrue: [err name = #'bad argument' ifFalse: [^OSErrorHolder badArgumentsSignal raise]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self netNameByAddress: aByteArray]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aByteArray]. ^OSErrorHolder errorSignal raise]. OSErrorHolder unsupportedOperationSignal raise! protocolNameByNumber: aSmallInteger "returns a String which is the protocol name for the given IP protocol number." err isError ifTrue: [err name = #'bad argument' ifFalse: [^OSErrorHolder badArgumentsSignal raise]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self protocolNameByNumber: aSmallInteger]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aSmallInteger]. ^OSErrorHolder errorSignal raise]. OSErrorHolder unsupportedOperationSignal raise! protocolNumberByName: aString "returns a SmallInteger which is the IP protocol number of the named protocol." err isError ifTrue: [err name = #'bad argument' ifTrue: [aString class == String defaultPlatformClass ifTrue: [^OSErrorHolder badArgumentsSignal raise] ifFalse: [^self protocolNumberByName: (String defaultPlatformClass fromString: aString)]]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aString]. ^OSErrorHolder errorSignal raise]. ^OSErrorHolder unsupportedOperationSignal raise! serviceNameByPort: aByteArray "returns a String which is the service name for the given IP port number." err isError ifTrue: [err name = #'bad argument' ifFalse: [^OSErrorHolder badArgumentsSignal raise]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self serviceNameByPort: aByteArray]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aByteArray]. ^OSErrorHolder errorSignal raise]. OSErrorHolder unsupportedOperationSignal raise! servicePortByName: aString "returns a ByteArray which is the IP port number of the named service." err isError ifTrue: [err name = #'bad argument' ifTrue: [aString class == String defaultPlatformClass ifTrue: [^OSErrorHolder badArgumentsSignal raise] ifFalse: [^self servicePortByName: (String defaultPlatformClass fromString: aString)]]. err name = #'allocation failed' ifTrue: [err handleErrorFor: self. ^self servicePortByName: aString]. err name = #'no match' ifTrue: [^OSErrorHolder inaccessibleSignal raiseWith: aString]. ^OSErrorHolder errorSignal raise]. ^OSErrorHolder unsupportedOperationSignal raise! ! !IPSocketAddress class methodsFor: 'addressing'! anyAddress "The IP broadcast address." "Someday, the broadcast address value will be 255 instead of 0." ^ByteArray with: 0 with: 0 with: 0 with: 0! broadcastAddressForNet: ba "Construct an IP broadcast address, given a network address." "Someday, the broadcast address value will be 255 instead of 0." ^(ByteArray new: 4) replaceBytesFrom: 1 to: ba size with: ba startingAt: 1! thisHost "The wildcard 'thisHost' address." ^ByteArray with: 0 with: 0 with: 0 with: 0! ! !IPSocketAddress class methodsFor: 'constants'! anyPort "Answer the anonymouse port number." ^0! firstUnreservedPort "Answer the first port number which is not reserved for WKPs." ^1024! maxPort "Answer the largest legal port number." ^16rFFFF! ! !IPSocketAddress class methodsFor: 'documentation'! allAboutHostAddresses "IP host addresses are 4 bytes long and are made up of a network number and a host-on-network number. (Normally, though, we treat a host address as if it doesn't have any substructure.) An IP host address doesn't really just identify a particular host, it identifies a particular network interface on a particular host. Therefore, one host may have several host addresses. Host addresses by convention are printed as 4 decimal bytes with periods in between, viz: 192.9.200.2 When we need to deal with host or network addresses as such (rather than embedded in a socket address) we just use (4-byte) ByteArrays. Just in case you're interested -- there are 3 types of network addresses: class A: 1-byte network number, 3-byte host number. class B: 2-byte network number, 2-byte host number. class C: 3-byte network number, 1-byte host number. ...that is, there are a few class-A networks (where each can have very many hosts), there are a moderate number of class-B networks (where each can have a moderate number of hosts) and there are many class-C networks (where each can have a small number of hosts). Determination of network classes is made by the value of the first byte of a host address; small numbers are class-A, big numbers are class-C and the ones in-between are class-B. Most networks are class-C (natch!!). This story gets more complicated in the case of subnets, which we won't discuss here. Broadcast addresses on a given network are formed by using as many zero bytes as needed to fill in the host number (someday, we're told, bytes with the value 255 will be used instead). So, to reach all the hosts on the Arpanet (which is the class-A network #10) use: 10.0.0.0 ...and to reach all the hosts on a class-B network numbered 192.9.100 use: 192.9.100.0 There is no standard way to form multicast addresses in the IP domain. Just to make things confusing, an all-zero IP address is used to identify the current host to the BSD IP implementation. That is, 0.0.0.0 means this-host through any available network interface. When a client wants to reach a server on the current host, the address 127.0.0.1 ('localhost') is used. " ^self error: 'comment only'! allAboutHostNames "People prefer to refer to hosts using a name rather than a string of digits. So IP implementations usually have some sort of name-to-address directory in which an address can be looked up dynamically. To deal with the case where you have a host number but no name, all the routines which deal with host names (which are Strings) can accept numeric strings in canonical format (i.e. 192.9.100.4). The class protocol ''naming utilities'' has methods to convert to/from host-names and host-addresses. " ^self error: 'comment only'! allAboutPortNumbersAndNames "Port numbers are necessarily part of socket addresses because more than just a host-address is needed to identify a communicating entity on a given host. That is, since each socket on a host needs a unique socket address and there will be many sockets with the same , we need another field to provide uniqueness. IP port numbers are 2 bytes long and are normally treated as a 16-bit positive number. Some port numbers are assigned in advance (Well Known Ports) and correspond to some standard service's connection-port. Sockets which are not created for these standard purposes are dynamically assigned port numbers. As with hosts names, programmers prefer to refer to standard services using a name rather than a string of digits. So IP implementations usually have some sort of serviceName-to-portNumber directory. The class protocol ''naming utilities'' has methods to convert to/from service-names and port-numbers. Assigning a new standard port number is an issue too complicated to be covered here. If you want to install a name-to-number correspondence that will have effect only on your local network, there will be platform-specific means to configure your local name-service. (On Suns, this is done with the Yellow Pages). If your service is transient, or otherwise not appropriate for assigning a Well-Known Port-Number, you have 2 alternatives: 1) Pick a random number between IPSocketAddress firstUnreservedPort and IPSocketAddress maxPort inclusive and hard-code this number into your client and server implementation. Hope that no-one on the hosts you will be using has made the same choice. 2) Let the system assign one for you (each time you start a server) by fire-ing up a server which creates a socket using port: IPSocketAddress anyPort then do a getName on that socket, print the port number and supply it to the client when you start it up. " ^self error: 'comment only'! ! SocketAddress initialize! SocketAccessor initialize! 'From VisualWorks(TM), Release 1.0 of 8 October 1992 on 21 August 1994 at 8:31:06 pm'! !TextAttributes class methodsFor: 'class initialization'! initializehtmlDefault | style cStyle | style := self new. cStyle := CharacterAttributes newWithDefaultAttributes. cStyle setDefaultQuery: (FontDescription new family: #('times' '*'); fixedWidth: false; serif: false; italic: false; boldness: 0.5; pixelSize: 16). style setCharacterAttributes: cStyle. cStyle at: #veryLarge put: [ :fontDesc | fontDesc pixelSize: 24]. style lineGrid: 27; baseline: 20; firstIndent: 0; restIndent: 0; rightIndent: 0. self styleNamed: #htmlDefault put: style! ! TextAttributes initializehtmlDefault! 'From VisualWorks(R) Release 2.0 of 4 August 1994 on 4 March 1995 at 5:43:05 pm'! !VisualComponent methodsFor: 'hit detection'! hitDetect: aPoint (self containsPoint: aPoint) ifTrue: [^self]. ^nil! ! !Wrapper methodsFor: 'hit detection'! hitDetect: aPoint ^self! ! !CompositePart methodsFor: 'hit detection'! hitDetect: aPoint "Answer a component that contains point aPoint or nil." components size to: 1 by: -1 do: [:i | | c | c := components at: i. (c containsPoint: aPoint) ifTrue: [^c]]. ^nil! ! !Character methodsFor: 'converting'! asString ^String with: self! ! Random subclass: #BetterRandom instanceVariableNames: 'transformBlock ' classVariableNames: '' poolDictionaries: '' category: 'New-Random'! !BetterRandom methodsFor: 'accessing'! next "return the next random number, having transformed it by the block" ^transformBlock value: super next! ! !BetterRandom methodsFor: 'private'! initialize "emulate my super" self transformBlock: [:x | x]! transformBlock: aBlock "aBlock should be a one-argument block -- the argument is the 'raw' random number" transformBlock := aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BetterRandom class instanceVariableNames: ''! !BetterRandom class methodsFor: 'examples'! exampleCollection1 "Interval as argument" "BetterRandom exampleCollection1" | rand | rand := BetterRandom fromCollection: (1 to: 13 by: 0.7). 10 timesRepeat: [Transcript show: rand next printString; cr]! exampleCollection2 "SequenceableCollection as argument" "BetterRandom exampleCollection2" | rand | rand := BetterRandom fromCollection: ColorValue constantNames. 10 timesRepeat: [Transcript show: rand next printString; cr]! exampleCollection3 "Set as argument" "BetterRandom exampleCollection3" | rand | rand := BetterRandom fromCollection: Object subclasses. 10 timesRepeat: [Transcript show: rand next printString; cr]! exampleFloat "BetterRandom exampleFloat" | rand | rand := BetterRandom floatBetween: 4 and: 13. 10 timesRepeat: [Transcript show: rand next printString; cr]! exampleInteger "BetterRandom exampleInteger" | rand | rand := BetterRandom integerBetween: 4 and: 13. 10 timesRepeat: [Transcript show: rand next printString; cr]! ! !BetterRandom class methodsFor: 'instance creation'! floatBetween: start and: stop | size | size := stop - start. size > 0 ifFalse: [^self error: 'non-positive range']. ^self fromBlock: [:x | x * size + start ]! fromBlock: aBlock "aBlock should be a one-argument block -- the argument is the 'raw' random number" ^self new transformBlock: aBlock! fromCollection: aCollection "Create an instance of me which will return a random element from the argument" | size aSequenceableCollection | aSequenceableCollection := aCollection isSequenceable ifFalse: [aCollection asOrderedCollection] ifTrue: [aCollection]. size := aSequenceableCollection size. size > 0 ifFalse: [^self error: 'Empty collection']. ^self fromBlock: [:x | | index | index := (x * size + 1) truncated. aSequenceableCollection at: index]! integerBetween: start and: stop | size | size := stop - start. size > 0 ifFalse: [^self error: 'non-positive range']. ^self fromBlock: [:x | (x * size + start) truncated]! new ^super new initialize! ! ' .ApplicationSource PNM-Reader(1.2)'! 'From VisualWorks(R) Release 2.0 of 4 August 1994 on 31 March 1995 at 6:00:52 am'! '- sources of PNM-Reader(1.2) -'! ImageReader subclass: #PNMImageReader instanceVariableNames: 'asciiFlag ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Images'! !PNMImageReader methodsFor: 'attributes'! format "Answer a string naming the format used to store the image." ^'Portable aNy Map (PNM)'! ! !PNMImageReader methodsFor: 'private-subclass responsibilty'! initializePalette ^self subclassResponsibility! nextPixelValue ^self subclassResponsibility! readParameters ^self subclassResponsibility! ! !PNMImageReader methodsFor: 'private'! magicNumbers ^self class magicNumbers! readImageData | pixelValue | asciiFlag ifFalse: [ioStream upTo: Character cr. ioStream binary]. (0 to: height - 1) do: [:y | (0 to: width - 1) do: [:x | pixelValue := self nextPixelValue. image atPoint: x @ y put: pixelValue]]! skipJunk ioStream skipSeparators. [ioStream peek = $#] whileTrue: [ioStream upTo: Character cr]. ioStream skipSeparators.! ! !PNMImageReader methodsFor: 'initialize-release'! readImage "Read the image stored the input stream." "import Portable aNyMap (PNM) format as of Jef Poskanzers Portable Bitmap Package." | pnmType | Stream endOfStreamSignal handle: [:ex | ex restartDo: [self formatError: 'Image data ended prematurely.']] do: [ioStream text. pnmType := (ioStream next: 2) asSymbol. asciiFlag := pnmType = (self magicNumbers at: 1). self readParameters. self initializePalette. self initializeImage. self readImageData]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !PNMImageReader class methodsFor: 'private'! checkFileExtensionFor: aFilenameOrString ^'*.pnm' match: aFilenameOrString asString! magicNumbers "Answer the right magic numbers for this class (See also class protocol>documentation)." ^#()! ! !PNMImageReader class methodsFor: 'documentation'! pnmFiles "The following is the UNIX manual page on pnm: NAME pnm - portable anymap file format DESCRIPTION The pnm programs operate on portable bitmaps, graymaps, and pixmaps, produced by the PBM, PGM, and PPM toolkits. There is no file format associated with pnm itself."! ! PNMImageReader subclass: #PPMImageReader instanceVariableNames: 'bitsPerColor ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Images'! !PPMImageReader methodsFor: 'private'! initializePalette | mask | mask := self makeMask. palette := FixedPalette redShift: 0 redMask: mask greenShift: bitsPerColor greenMask: mask blueShift: bitsPerColor * 2 blueMask: mask! makeMask "Answers a bit mask with the least bitsPerColor bits set." ^(2 raisedTo: bitsPerColor) - 1! nextPixelValue | red green blue | asciiFlag ifTrue: [self skipJunk. red := Integer readFrom: ioStream. self skipJunk. green := Integer readFrom: ioStream. self skipJunk. blue := Integer readFrom: ioStream] ifFalse: [red := ioStream next. green := ioStream next. blue := ioStream next]. ^((blue bitShift: bitsPerColor * 2) bitOr: (green bitShift: bitsPerColor)) bitOr: red.! readParameters "Read image parameters" | w h maxValue | self skipJunk. w := Integer readFrom: ioStream. self skipJunk. h := Integer readFrom: ioStream. self skipJunk. maxValue := Integer readFrom: ioStream. bitsPerColor := (maxValue + 1 log: 2) ceiling. "for each of r, g, b" self width: w height: h bitsPerPixel: bitsPerColor * 3! ! !PPMImageReader methodsFor: 'attributes'! format "Answer a string naming the format used to store the image." ^'Portable Pixmap (PPM)'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !PPMImageReader class methodsFor: 'documentation'! ppmFiles "The following is the UNIX manual page on ppm: NAME ppm - portable pixmap file format DESCRIPTION The portable pixmap format is a lowest common denominator color image file format. The definition is as follows: - A 'magic number' for identifying the file type. A ppm file's magic number is the two characters 'P3'. - Whitespace (blanks, TABs, CRs, LFs). - A width, formatted as ASCII characters in decimal. - Whitespace. - A height, again in ASCII decimal. - Whitespace. - The maximum color-component value, again in ASCII decimal. - Whitespace. - Width * height pixels, each three ASCII decimal values between 0 and the specified maximum value, starting at the top-left corner of the pixmap, proceding in normal English reading order. The three values for each pixel represent red, green, and blue, respectively; a value of 0 means that color is off, and the maximum value means that color is maxxed out. - Characters from a '#' to the next end-of-line are ignored (comments). - No line should be longer than 70 characters. Here is an example of a small pixmap in this format: P3 # feep.ppm 4 4 15 0 0 0 0 0 0 0 0 0 15 0 15 0 0 0 0 15 7 0 0 0 0 0 0 0 0 0 0 0 0 0 15 7 0 0 0 15 0 15 0 0 0 0 0 0 0 0 0 Programs that read this format should be as lenient as pos- sible, accepting anything that looks remotely like a pixmap. There is also a variant on the format, available by setting the RAWBITS option at compile time. This variant is dif- ferent in the following ways: - The 'magic number' is 'P6' instead of 'P3'. - The pixel values are stored as plain bytes, instead of ASCII decimal. - Whitespace is not allowed in the pixels area. - The files are smaller and many times faster to read and write. Note that this raw format can only be used for maxvals less than or equal to 255. If you use the PPM library and try to write a file with a larger maxval, it will automatically fall back on the slower but more general ASCII format."! ! !PPMImageReader class methodsFor: 'private'! canRead: aFilenameOrString "Answer whether the receiver can read the named file." | pattern | pattern := #('*.ppm') detect: [:p | p match: aFilenameOrString asString] ifNone: [nil]. pattern notNil ifTrue: [^true]. ^Object errorSignal handle: [:ex | ex returnWith: false] do: [| inputStream | inputStream := aFilenameOrString asFilename readStream text. [self magicNumbers includes: (inputStream next: 2)] valueNowOrOnUnwindDo: [inputStream close]]! checkFileExtensionFor: aFilenameOrString ^'*.ppm' match: aFilenameOrString asString! magicNumbers "Answer the right magic numbers for this class (See also class protocol>documentation)." ^#(P3 P6)! ! PNMImageReader subclass: #PGMImageReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Images'! !PGMImageReader methodsFor: 'attributes'! format "Answer a string naming the format used to store the image." ^'Portable Grayscale Map (PGM)'! ! !PGMImageReader methodsFor: 'private'! initializePalette | colors | colors := Array new: (2 raisedTo: bitsPerPixel). 1 to: colors size do: [:i | colors at: i put: (ColorValue brightness: i - 1 / (colors size - 1))]. palette := MappedPalette withColors: colors.! nextPixelValue ^asciiFlag ifTrue: [self skipJunk. Integer readFrom: ioStream] ifFalse: [ioStream next]! readParameters "Read image parameters" | w h maxValue bpp | self skipJunk. w := Integer readFrom: ioStream. self skipJunk. h := Integer readFrom: ioStream. self skipJunk. maxValue := Integer readFrom: ioStream. bpp := (maxValue + 1 log: 2) ceiling. self width: w height: h bitsPerPixel: bpp.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !PGMImageReader class methodsFor: 'documentation'! pgmFiles "The following is the UNIX manual page on pgm: NAME pgm - portable graymap file format DESCRIPTION The portable graymap format is a lowest common denominator grayscale file format. The definition is as follows: - A 'magic number' for identifying the file type. A pgm file's magic number is the two characters 'P2'. - Whitespace (blanks, TABs, CRs, LFs). - A width, formatted as ASCII characters in decimal. - Whitespace. - A height, again in ASCII decimal. - Whitespace. - The maximum gray value, again in ASCII decimal. - Whitespace. - Width * height gray values, each in ASCII decimal, between 0 and the specified maximum value, separated by whi- tespace, starting at the top-left corner of the graymap, proceding in normal English reading order. A value of 0 means black, and the maximum value means white. - Characters from a '#' to the next end-of-line are ignored (comments). - No line should be longer than 70 characters. Here is an example of a small graymap in this format: P2 # feep.pgm 24 7 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0 0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0 0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 Programs that read this format should be as lenient as pos- sible, accepting anything that looks remotely like a gray- map. There is also a variant on the format, available by setting the RAWBITS option at compile time. This variant is dif- ferent in the following ways: - The 'magic number' is 'P5' instead of 'P2'. - The gray values are stored as plain bytes, instead of ASCII decimal. - No whitespace is allowed in the grays section. - The files are smaller and many times faster to read and write. Note that this raw format can only be used for maxvals less than or equal to 255. If you use the PGM library and try to write a file with a larger maxval, it will automatically fall back on the slower but more general ASCII format."! ! !PGMImageReader class methodsFor: 'private'! canRead: aFilenameOrString "Answer whether the receiver can read the named file." ('*.pgm' match: aFilenameOrString asString) ifTrue: [^true]. ^Object errorSignal handle: [:ex | ex returnWith: false] do: [| inputStream | inputStream := aFilenameOrString asFilename readStream text. [self magicNumbers includes: (inputStream next: 2) asSymbol] valueNowOrOnUnwindDo: [inputStream close]]! checkFileExtensionFor: aFilenameOrString ^('*.pgm' match: aFilenameOrString asString)! magicNumbers "Answer the right magic numbers for this class (See also class protocol>documentation)." ^#( P2 P5 )! ! PNMImageReader subclass: #PBMImageReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Images'! !PBMImageReader methodsFor: 'attributes'! format "Answer a string naming the format used to store the image." ^'Portable Bitmap (PBM)'! ! !PBMImageReader methodsFor: 'private'! initializePalette palette := MappedPalette monochromeDefault! nextPixelValue ^asciiFlag ifTrue: [self skipJunk. Integer readFrom: ioStream] ifFalse: [self error: 'internal error: should never read raw data with method nextPixelValue']! readImageData asciiFlag ifTrue: [^super readImageData]. ioStream upTo: Character cr. ioStream binary. (0 to: height - 1) do: [:y | self readPackedRow: y]! readPackedRow: row "Read a pixelrow of the 1-bit-deep image. Each byte contains 8 pixels." | packedRow | packedRow := ByteArray new: bytesPerRow. (1 to: rowEndOffset + 1) do: [:i | | byte | byte := ioStream next. "byte := self mirror: byte." packedRow at: i put: byte]. image packedRowAt: row putAll: packedRow! readParameters "Read image parameters." | w h | self skipJunk. w := Integer readFrom: ioStream. self skipJunk. h := Integer readFrom: ioStream. self width: w height: h bitsPerPixel: 1! ! !PBMImageReader methodsFor: 'initialize-release'! readImage "Read the image stored the input stream." | pnmType | Stream endOfStreamSignal handle: [:ex | ex restartDo: [self formatError: 'Image data ended prematurely.']] do: [ioStream text. pnmType := (ioStream next: 2) asSymbol. asciiFlag := pnmType = (self magicNumbers at: 1). self readParameters. self initializePalette. self initializeImage. self readImageData]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !PBMImageReader class methodsFor: 'private'! canRead: aFilenameOrString "Answer whether the receiver can read the named file." | pattern | pattern := #('*.pbm') detect: [:p | p match: aFilenameOrString asString] ifNone: [nil]. pattern notNil ifTrue: [^true]. ^Object errorSignal handle: [:ex | ex returnWith: false] do: [| inputStream | inputStream := aFilenameOrString asFilename readStream text. [self magicNumbers includes: (inputStream next: 2) asSymbol] valueNowOrOnUnwindDo: [inputStream close]]! checkFileExtensionFor: aFilenameOrString ^'*.pbm' match: aFilenameOrString asString! magicNumbers "Answer the right magic numbers for this class (See also class protocol>documentation)." ^#(#P1 #P4)! ! !PBMImageReader class methodsFor: 'documentation'! pbmFiles "The following is the UNIX manual page on pbm: NAME pbm - portable bitmap file format DESCRIPTION The portable bitmap format is a lowest common denominator monochrome file format. It was originally designed to make it reasonable to mail bitmaps between different types of machines using the typical stupid network mailers we have today. Now it serves as the common language of a large fam- ily of bitmap conversion filters. The definition is as fol- lows: - A 'magic number' for identifying the file type. A pbm file's magic number is the two characters 'P1'. - Whitespace (blanks, TABs, CRs, LFs). - A width, formatted as ASCII characters in decimal. - Whitespace. - A height, again in ASCII decimal. - Whitespace. - Width * height bits, each either '1' or '0', starting at the top-left corner of the bitmap, proceding in normal English reading order. - The character '1' means black, '0' means white. - Whitespace in the bits section is ignored. - Characters from a '#' to the next end-of-line are ignored (comments). - No line should be longer than 70 characters. Here is an example of a small bitmap in this format: P1 # feep.pbm 24 7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 1 0 0 1 1 1 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 1 1 1 1 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 Programs that read this format should be as lenient as pos- sible, accepting anything that looks remotely like a bitmap. There is also a variant on the format, available by setting the RAWBITS option at compile time. This variant is dif- ferent in the following ways: - The 'magic number' is 'P4' instead of 'P1'. - The bits are stored eight per byte, high bit first low bit last. - No whitespace is allowed in the bits section. - The files are eight times smaller and many times faster to read and write."! ! ' .ApplicationSource XBM-Reader(1.0)'! 'From VisualWorks(R) Release 2.0 of 4 August 1994 on 31 March 1995 at 6:00:39 am'! '- sources of XBM-Reader(1.0) -'! ImageReader subclass: #XBMReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Images'! !XBMReader methodsFor: 'attributes'! format "Answer a string naming the format used to store the image." ^'X11 Bitmap (XBM)'! ! !XBMReader methodsFor: 'private'! mirror: byte "reverse bit order in a byte. Should be moved to SmallInteger" | etyb maskIn maskOut | etyb := 0. maskIn := 1. maskOut := 128. 8 timesRepeat: [(byte bitAnd: maskIn) isZero ifFalse: [etyb := etyb bitOr: maskOut]. maskIn := maskIn bitShift: 1. maskOut := maskOut bitShift: -1]. ^etyb! readImageData | packedRow | ioStream throughAll: 'static'. ioStream skipUpTo: ${; next. packedRow := ByteArray new: bytesPerRow. (0 to: height - 1) do: [:row | (1 to: rowEndOffset + 1) do: [:i | | byte | ioStream skipSeparators. ioStream next; next. byte := Integer readFrom: ioStream radix: 16. byte := self mirror: byte. ioStream next. packedRow at: i put: byte]. image packedRowAt: row putAll: packedRow]! readParameter: aString ioStream skipSeparators. ioStream throughAll: aString. ioStream skipSeparators. ^Integer readFrom: ioStream! ! !XBMReader methodsFor: 'initialize-release'! readImage "Read the image stored the input stream." "import X bitmap file as Depth1Image" | depth w h | (ioStream respondsTo: #text) ifTrue: ["set mode to character" ioStream text]. ioStream lineEndLF. Stream endOfStreamSignal handle: [:ex | ex restartDo: [self formatError: 'Image data ended prematurely.']] do: [palette := MappedPalette monochromeDefault. depth := 1. w := self readParameter: 'width'. h := self readParameter: 'height'. self width: w height: h bitsPerPixel: depth. self initializeImage. self readImageData]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !XBMReader class methodsFor: 'private'! canRead: aFilenameOrString "Answer whether the receiver can read the named file." ('*.xbm' match: aFilenameOrString asString) ifTrue: [^true]. ^Object errorSignal handle: [:ex | ex returnWith: false] do: [| inputStream token | token := '#define'. inputStream := aFilenameOrString asFilename readStream. [token = (inputStream nextAvailable: token size)] valueNowOrOnUnwindDo: [inputStream close]]! ! !XBMReader class methodsFor: 'documentation'! xbmFiles "The following is an extract of the UNIX manual entry for 'bitmap': FILE FORMAT The Write Output command stores bitmaps as simple C program fragments that can be compiled into programs, referred to by X Toolkit pixmap resources, manipulated by other programs (see xsetroot), or read in using utility routines in the various programming libraries. The width and height of the bitmap as well as the hotspot, if specified, are written as preprocessor symbols at the start of the file. The bitmap image is then written out as an array of characters: #define name_width 11 #define name_height 5 #define name_x_hot 5 #define name_y_hot 2 static char name_bits[] = { 0x91, 0x04, 0xca, 0x06, 0x84, 0x04, 0x8a, 0x04, 0x91, 0x04 }; The name prefix to the preprocessor symbols and to the bits array is constructed from the filename argument given on the command line. Any directories are stripped off the front of the name and any suffix beginning with a period is stripped off the end. Any remaining non-alphabetic characters are replaced with underscores. The name_x_hot and name_y_hot symbols will only be present if a hotspot has been desig- nated using the Set Hot Spot command. Each character in the the array contains 8 bits from one row of the image (rows are padded out at the end to a multiple of 8 to make this is possible). Rows are written out from left to right and top to bottom. The first character of the array holds the leftmost 8 bits of top line, and the last characters holds the right most 8 bits (including padding) of the bottom line. Within each character, the leftmost bit in the bitmap is the least significant bit in the character. This process can be demonstrated visually by splitting a row into words containing 8 bits each, reversing the bits each word (since Arabic numbers have the significant digit on the right and images have the least significant bit on the left), and translating each word from binary to hexadecimal. In the following example, the array of 1's and 0's on the left represents a bitmap containing 5 rows and 11 columns that spells X11. To its right is is the same array split into 8 bit words with each row padded with 0's so that it is a multiple of 8 in length (16): 10001001001 10001001 00100000 01010011011 01010011 01100000 00100001001 00100001 00100000 01010001001 01010001 00100000 10001001001 10001001 00100000 Reversing the bits in each word of the padded, split version of the bitmap yields the left hand figure below. Interpret- ing each word as hexadecimal number yields the array of numbers on the right: 10010001 00000100 0x91 0x04 11001010 00000110 0xca 0x06 10000100 00000100 0x84 0x04 10001010 00000100 0x8a 0x04 10010001 00000100 0x91 0x04 The character array can then be generated by reading each row from left to right, top to bottom: static char name_bits[] = { 0x91, 0x04, 0xca, 0x06, 0x84, 0x04, 0x8a, 0x04, 0x91, 0x04 }; "! ! ' .ApplicationSource GIF-Reader(1.1)'! 'From VisualWorks(R) Release 2.0 of 4 August 1994 on 25 November 1994 at 12:17:08 am'! '- sources of GIF-Reader(1.1) -'! ReadStream subclass: #FilterStream instanceVariableNames: 'stream ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-GIF Reading'! FilterStream comment: 'FilterStream processes data from another stream and presents it to its client with a streaming interface again. This allows FilterStreams and other streams to be composed freely. The current implementation only allows for reading, not for writing. Instance Variables: stream stream from which data is read'! !FilterStream methodsFor: 'initialize-release'! close stream == nil ifFalse: [stream close. stream := nil]! stream: aStream stream := aStream. self initialize! ! !FilterStream methodsFor: 'accessing'! atEnd super atEnd ifFalse: [^false]. self pastEnd == nil ifTrue: [^true]. self skip: -1. ^false! stream ^stream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !FilterStream class methodsFor: 'instance creation'! on: aStream ^self basicNew stream: aStream! ! FilterStream subclass: #GIFLZWReader instanceVariableNames: 'bits avail codeSize readMask bitMask clearCode eofCode freeCode oldCode prefix suffix initCodeSize maxCode finChar ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-GIF Reading'! GIFLZWReader comment: 'This class implements the variant of Lempel-Ziv decoding used by the GIF file format. This is somewhat different from Unix compress, but uses mainly the same mechanisms. Instance Variables: bits the low-order bits of this are available for reading avail number of valid bits in ''bits'' codeSize number of bits in a code word readMask (1 raisedTo: codeSize)-1 bitMask mask for data (not code) values clearCode code value that clears the table eofCode code value that signals end-of-file freeCode next available code value oldCode last code value prefix code values that constitute a linked list of previous codes suffix data value corresponding to a code initCodeSize the initial code size; used to reset the codeSize when a clearCode is encountered maxCode maximum possible code value+1 finChar the last data value'! !GIFLZWReader methodsFor: 'initialize-release'! bitMask: mask bitMask := mask! initCodeSize: aNumber self codeSize: aNumber. initCodeSize := aNumber. clearCode := maxCode//2. eofCode := clearCode+1. freeCode := clearCode+2! initialize bits := avail := 0. collection := ByteArray new: 4097. position := readLimit := 0. prefix := WordArray new: 4096. suffix := ByteArray new: 4096! ! !GIFLZWReader methodsFor: 'private'! codeSize: aNumber aNumber <= 12 ifTrue: [codeSize := aNumber. maxCode := 1 bitShift: aNumber. readMask := maxCode - 1]! nextCode | result | [codeSize > avail] whileTrue: [bits := bits + (stream next bitShift: avail). avail := avail + 8]. result := bits bitAnd: readMask. bits := bits bitShift: 0 - codeSize. avail := avail - codeSize. ^result! pastEnd | code curCode inCode | code := self nextCode. code == eofCode ifTrue: [^nil]. code == clearCode ifTrue: [self codeSize: initCodeSize. freeCode := clearCode + 2. code := self nextCode. curCode := oldCode := code. finChar := code bitAnd: bitMask. collection at: 1 put: finChar. position := readLimit := 1. ^finChar]. curCode := inCode := code. position := collection size. readLimit := collection size. code >= freeCode ifTrue: [curCode := oldCode. collection at: position put: finChar. position := position - 1]. [curCode > bitMask] whileTrue: [collection at: position put: (suffix at: curCode). position := position - 1. curCode := prefix at: curCode]. finChar := curCode bitAnd: bitMask. collection at: position put: finChar. prefix at: freeCode put: oldCode. suffix at: freeCode put: finChar. freeCode := freeCode + 1. oldCode := inCode. freeCode >= maxCode ifTrue: [self codeSize: codeSize + 1]. ^finChar! ! ImageReader subclass: #GIFImageReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-GIF Reading'! GIFImageReader comment: 'This class reads GIF images. Currently, many features of the GIF protocol are not handled correctly, such as interleave or multiple images. It''s just enough to read images written out by the XV program...'! !GIFImageReader methodsFor: 'initialize-release'! readHeader "read the header" | flags | ioStream skip: 6. width := self nextLSBUnsignedShort. height := self nextLSBUnsignedShort. flags := ioStream next. ioStream next. "background; not used" ioStream next. "aspect/gif89a; not used" bitsPerPixel := (flags bitAnd: 7) + 1. (flags anyMask: 128) ifTrue: [self readPalette]! readImage self readHeader. self readImageData! readImageData "read next image" | len flags codeSize reader row | [ioStream peek = 33] whileTrue: [ioStream next; next. [(len := ioStream next) = 0] whileFalse: [ioStream skip: len]]. ioStream peek = 59 ifTrue: [^nil]. (ioStream peekFor: 44) ifFalse: [self error: 'unknown GIF tag.']. self nextLSBUnsignedShort; nextLSBUnsignedShort. width := self nextLSBUnsignedShort. height := self nextLSBUnsignedShort. flags := ioStream next. (flags anyMask: 128) ifTrue: [bitsPerPixel := (flags bitAnd: 7) + 1. self readPalette]. codeSize := ioStream next. reader := GIFLZWReader on: (GIFDataBlockReader on: ioStream). reader initCodeSize: codeSize+1; bitMask: palette maxIndex. self initializeImage. row := ByteArray new: width. 0 to: image height - 1 do: [:y | reader next: width into: row startingAt: 1. image rowAt: y putAll: row].! ! !GIFImageReader methodsFor: 'private'! readPalette palette := MappedPalette withColors: ((1 to: (1 bitShift: bitsPerPixel)) collect: [:i | ColorValue red: ioStream next / 255 green: ioStream next / 255 blue: ioStream next / 255])! ! !GIFImageReader methodsFor: 'attributes'! format ^'GIF'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! !GIFImageReader class methodsFor: 'private'! canRead: aFilenameOrString ('*.gif' match: aFilenameOrString asString) ifTrue: [^true]. ^Object errorSignal handle: [:ex | ex returnWith: false] do: [| inputStream magic | inputStream := aFilenameOrString asFilename readStream. [magic := inputStream next: 6. magic = 'gif87a' or: [magic = 'gif89a']] valueNowOrOnUnwindDo: [inputStream close]]! ! FilterStream subclass: #GIFDataBlockReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-GIF Reading'! GIFDataBlockReader comment: 'This class implements unpacking for GIF data blocks. GIF data is normally written as a sequence of block with length < 256; starting with a length byte. A length byte of 0 signals end-of-data. Example: (GIFDataBlockReader on: #[ 4 16r44 16r61 16r74 16r61 "first block: 4 bytes ''Data''" 0 "end of data" ] readStream) upToEnd asString'! !GIFDataBlockReader methodsFor: 'initialize-release'! initialize collection := ByteArray new: 255. position := readLimit := 0! ! !GIFDataBlockReader methodsFor: 'private'! pastEnd | blockSize | blockSize := stream peek. blockSize = 0 ifTrue: [^nil]. stream next; next: blockSize into: collection startingAt: 1. position := 1. readLimit := blockSize. ^collection at: 1! ! 'From VisualWorks(R) Release 2.0 of 4 August 1994 on 1 June 1995 at 5:00:07 pm'! !GIFImageReader methodsFor: 'private'! constructGrouping: aNumber "Answer the interlace grouping array for an image aNumber pixels high" | grouping j i | grouping := Array new: height. j := 0. i := 1. [i <= height] whileTrue: [j := j + 1. grouping at: j put: i. i := i + 8]. i := 5. [i <= height] whileTrue: [j := j + 1. grouping at: j put: i. i := i + 8]. i := 3. [i <= height] whileTrue: [j := j + 1. grouping at: j put: i. i := i + 4]. i := 2. [i <= height] whileTrue: [j := j + 1. grouping at: j put: i. i := i + 2]. ^grouping! ! !GIFImageReader methodsFor: 'initialize-release'! readImageData "read next image" | len flags codeSize reader row interlace grouping y | [ioStream peek = 33] whileTrue: [ioStream next; next. [(len := ioStream next) = 0] whileFalse: [ioStream skip: len]]. ioStream peek = 59 ifTrue: [^nil]. (ioStream peekFor: 44) ifFalse: [self error: 'unknown GIF tag.']. self nextLSBUnsignedShort; nextLSBUnsignedShort. width := self nextLSBUnsignedShort. height := self nextLSBUnsignedShort. flags := ioStream next. "Is this image interlaced? If so, construct a grouping array" interlace := ((flags bitAt: 7) ~= 0). interlace ifTrue: [ grouping := self constructGrouping: height]. (flags anyMask: 128) ifTrue: [bitsPerPixel := (flags bitAnd: 7) + 1. self readPalette]. codeSize := ioStream next. reader := GIFLZWReader on: (GIFDataBlockReader on: ioStream). reader initCodeSize: codeSize+1; bitMask: palette maxIndex. self initializeImage. row := ByteArray new: width. 1 to: image height do: [:r | y := r. interlace ifTrue: [ y := grouping at: r]. y := y -1. reader next: width into: row startingAt: 1. image rowAt: y putAll: row].! ! VisualComponent subclass: #HorizontalLine instanceVariableNames: 'start end height leftOffset ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Support'! HorizontalLine comment: 'I am just a 3D horizontal line. '! !HorizontalLine methodsFor: 'displaying'! displayOn: aGraphicsContext | y| aGraphicsContext paint: ColorValue gray. aGraphicsContext displayLineFrom: start to: end. y := start y + 1. aGraphicsContext paint: ColorValue white. aGraphicsContext displayLineFrom: start x @ y to: end x @ y.! ! !HorizontalLine methodsFor: 'bounds accessing'! preferredBounds |width| width := end x - start x + leftOffset. ^start extent: width@(self height)! ! !HorizontalLine methodsFor: 'private'! defaultHeight ^30! ! !HorizontalLine methodsFor: 'accessing'! height height isNil ifTrue: [^self defaultHeight]. ^height! height: anInteger height := anInteger! width: anInteger start := leftOffset@10. end := anInteger @10! ! !HorizontalLine methodsFor: 'initialize-release'! initialize leftOffset := 10! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HorizontalLine class instanceVariableNames: ''! !HorizontalLine class methodsFor: 'instance creation'! new ^super new initialize! ! Stream subclass: #RandomFile instanceVariableNames: 'random dirFileName prefix suffix ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Support'! RandomFile comment: 'I am a random file generator. Instance Variables: random dirFilename prefix extension '! !RandomFile methodsFor: 'accessing'! next "Return the next random file." ^self nextWithPrefix: prefix suffix: suffix! nextWithPrefix: aFilenameString "Return the next random file." ^self nextWithPrefix: aFilenameString suffix: suffix! nextWithPrefix: prefixString suffix: suffixString "Return the next random file." | fileString | [| tmpFilename | fileString := prefixString , random next printString , suffixString. tmpFilename := Filename named: (dirFileName asString, fileString). tmpFilename exists] whileTrue. ^dirFileName construct: fileString! nextWithSuffix: aFilenameString "Return the next random file." ^self nextWithPrefix: prefix suffix: aFilenameString! ! !RandomFile methodsFor: 'private'! dirName: aDirString dirFileName := Filename named: aDirString! prefix: aString prefix := aString! random: aRandom random := aRandom! suffix: aString suffix := aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RandomFile class instanceVariableNames: ''! !RandomFile class methodsFor: 'instance creation'! dirName: dirString ^self dirName: dirString prefix: self defaultPrefix suffix: self defaultSuffix! dirName: dirString prefix: prefixString suffix: suffixString |g| g := self basicNew. g random: (BetterRandom integerBetween: 1 and: 9999999). g dirName: dirString; prefix: prefixString; suffix: suffixString. ^g! ! !RandomFile class methodsFor: 'private'! defaultPrefix ^'t'! defaultSuffix ^'.tmp'! ! Object subclass: #ResponseHeader instanceVariableNames: 'attributes httpVersion statusCode firstLine ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Support'! ResponseHeader comment: 'I am the responseHeader for HTTP 1.0 protocol. Instance Variables: attributes httpVersion statusCode firstLine '! !ResponseHeader methodsFor: 'initialize-release'! initialize attributes := Dictionary new.! ! !ResponseHeader methodsFor: 'accessing'! addAttributeName: aNameString value: aValueString attributes at: aNameString asLowercase put: aValueString! atAttribute: aNameString ^attributes at: aNameString asLowercase ifAbsent: nil! attributes ^attributes! firstLine ^firstLine! firstLine: aString firstLine := aString! httpVersion ^httpVersion! httpVersion: aString httpVersion := aString! mimeSubType | subTypeString colonIdx | subTypeString := self atAttribute: 'Content-Type'. colonIdx := subTypeString indexOf: $/. colonIdx = 0 ifFalse: [^(subTypeString copyFrom: colonIdx + 1 to: subTypeString size) asSymbol] ifTrue: [^#nil]! mimeType | typeString colonIdx | typeString := self atAttribute: 'Content-Type'. colonIdx := typeString indexOf: $/. colonIdx = 0 ifFalse: [^(typeString copyFrom: 1 to: colonIdx - 1) asSymbol] ifTrue: [^typeString asSymbol]! statusCode ^statusCode! statusCode: aString statusCode := aString! ! !ResponseHeader methodsFor: 'private'! crlf ^String with: Character cr with: Character lf! ! !ResponseHeader methodsFor: 'converting'! readStream | s | s := firstLine , self crlf. attributes keysAndValuesDo: [:attr :value | s := s , attr. value notNil ifTrue: [s := s , '=' , value]. s := s , self crlf]. ^s readStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ResponseHeader class instanceVariableNames: ''! !ResponseHeader class methodsFor: 'instance creation'! new ^super new initialize! ! Object subclass: #ResponseHeaderBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Support'! ResponseHeaderBuilder comment: 'I can parse a string and build a ResponseHeader in http protocol.'! !ResponseHeaderBuilder methodsFor: 'private'! parseFirstHeaderLine: aString to: aResponseHeader | slashIdx spaceIdx1 spaceIdx2 | slashIdx := aString indexOf: $/. spaceIdx1 := aString indexOf: Character space. spaceIdx2 := aString nextIndexOf: Character space from: spaceIdx1 + 1 to: aString size. aResponseHeader firstLine: aString. aResponseHeader httpVersion: (aString copyFrom: slashIdx + 1 to: spaceIdx1 - 1). aResponseHeader statusCode: (aString copyFrom: spaceIdx1 + 1 to: spaceIdx2 - 1)! parseHeaderLine: aString to: aResponseHeader | colonIdx attrName attrValue | aString = '' ifTrue: [^self]. colonIdx := aString indexOf: $:. colonIdx > 0 ifTrue: [attrName := aString copyFrom: 1 to: colonIdx - 1. attrValue := aString copyFrom: colonIdx + 2 to: aString size. aResponseHeader addAttributeName: attrName value: attrValue]! remove: aCharCollection from: aStream "If the next occurence of elements in aCharCollection from aStream." |oPos tmpCollection| oPos := aStream position. tmpCollection := aStream throughAll: aCharCollection. (tmpCollection size = aCharCollection size) ifFalse: [ aStream position: oPos ]! ! !ResponseHeaderBuilder methodsFor: 'accessing'! buildFrom: aStream delimiters: aCharCollection | firstLine header | header := ResponseHeader new. firstLine := aStream upToAll: aCharCollection. self parseFirstHeaderLine: firstLine to: header. [aStream atEnd] whileFalse: [| eachLine | self remove: aCharCollection from: aStream. eachLine := aStream upToAll: aCharCollection. self parseHeaderLine: eachLine to: header]. ^header! ! Object subclass: #Stack instanceVariableNames: 'content ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Support'! Stack comment: 'You''d better know who I am !! Instance Variables: content '! !Stack methodsFor: 'enumerating'! do: aBlock ^content do: aBlock! select: aBlock ^content select: aBlock! ! !Stack methodsFor: 'accessing'! clear "Clear all the elements in stack." self initialize! firstElement "Without poping, return the most bottom element in the stack" content isEmpty ifTrue: [^nil]. ^content first! lastElement "Without poping, return the last inserted element from the stack" content isEmpty ifTrue: [^nil]. ^content last! pop "Return the top element." content isEmpty ifTrue:[^nil]. ^content removeLast! push: anObject "Push anObject into the top of the stack. " content addLast: anObject! size ^content size! top "Without poping, return the most bottom element in the stack" content isEmpty ifTrue: [^nil]. ^content first! ! !Stack methodsFor: 'initialize-release'! initialize content := OrderedCollection new! ! !Stack methodsFor: 'testing'! isEmpty ^content isEmpty! ! !Stack methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'a Stack ( '. content do: [:each | aStream nextPutAll: ' ( '. each printOn: aStream. aStream nextPutAll: ' ) ']. aStream nextPutAll: ' ) '! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Stack class instanceVariableNames: ''! !Stack class methodsFor: 'instance creation'! new ^super new initialize! ! Text subclass: #StructuredText instanceVariableNames: 'structuralRuns ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Support'! StructuredText comment: 'For hypertext application, sometimes, different portions of a Text has different meanings. For example, "

This is an example for StructuredText" In the above HTML, it is formatted into a ComposedText with the text content "This is an example for StructuredText" The tag information is gone when it is displayed. Sometimes, we may want to know whether the letter $e in ''example'' is contained in the node , and sometimes we want to know if it is contained in the node

. I am capable of storing this information just like Text stores its emphasis. For example, in the above example, I would return #( node(H1), node(B)) if I receive the message structuresAt: 13, that is the position of the character $x in the word example. For structuresAt: 2, the $h in the word ''This'', I would return#( node(H1)). node(x) means a parse tree node with type x for the sake for this discussion. Instance Varialbes: structuralRuns of anything. '! !StructuredText methodsFor: 'private'! setStructures: anArray structuralRuns := anArray! structures ^structuralRuns! ! !StructuredText methodsFor: 'structures'! addStructure: newStructure removeStructure: oldStructure allowDuplicates: aBool structuralRuns := structuralRuns add: newStructure remove: oldStructure duplicate: aBool! ignoreCR: aBoolean! structureAllWith: anObject "Set the structure for all characters in the receiver to be the given structure." self structureFrom: 1 to: self size with: anObject! structureAt: characterIndex self size = 0 ifTrue: [^nil]. "null text tolerates access" ^structuralRuns at: characterIndex! structureFrom: start to: stop with: anObject "Set the structure for characters in the interval start-stop." structuralRuns := structuralRuns copyReplaceFrom: start to: stop with: (structuralRuns class new: stop - start + 1 withAll: anObject)! structuresAt: characterIndex | structures | self size = 0 ifTrue: [^nil]. "null text tolerates access" structures := structuralRuns at: characterIndex. structures size = 0 ifTrue: [^OrderedCollection with: structures] ifFalse: [^structures]! ! !StructuredText methodsFor: 'accessing'! replaceFrom: start to: stop with: aTextOrString | repText | repText := aTextOrString asText. string := string changeFrom: start to: stop with: repText string. runs := runs copyReplaceFrom: start to: stop with: repText runs. structuralRuns := structuralRuns copyReplaceFrom: start to: stop with: aTextOrString structures.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StructuredText class instanceVariableNames: ''! !StructuredText class methodsFor: 'instance creation'! fromString: aString ^self string: aString emphasis: nil structure: nil! string: aString emphasis: code structure: anObject | st | st := self string: aString asString runs: (RunArray new: aString size withAll: code). st setStructures: (RunArray new: aString size withAll: anObject). ^st! ! Object subclass: #Anchor instanceVariableNames: 'id value ' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! Anchor comment: 'I represent an anchor in hypertext systems. Instance Variables: id value '! !Anchor methodsFor: 'accessing'! id ^id! id: anObject id := anObject! value ^value! value: anObject value := anObject! ! Object subclass: #Attribute instanceVariableNames: 'value id ' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! Attribute comment: 'I represent an attribute in a HyperComponent. Instance Variales: id value '! !Attribute methodsFor: 'testing'! isAttributeName: aSymbol "Test if the receiver's attribute Name is the same as aString. Attribute name is case insensitive." ^id = aSymbol! ! !Attribute methodsFor: 'accessing'! id ^id! id: aSymbol id := aSymbol! name "Same as id. Put here so that it is compatible with previous version of HyperTalk." ^self id! name: anObject "Same as id:. Put here so that it is compatible with previous version of HyperTalk." ^self id: anObject! value ^value! value: anObject value := anObject! ! !Attribute methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self class printString , ' '. id notNil ifTrue: [aStream nextPutAll: id]. value notNil ifTrue: [aStream nextPutAll: ' =' , value printString]! ! Object subclass: #HyperComponent instanceVariableNames: 'attributes presentations anchors content type formatPolicy ' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! HyperComponent comment: 'I am the abstract super class for hypertext components. Instance Variables: attributes of Attribute presentations of anObject anchors of Anchor content type formatPolicy '! !HyperComponent methodsFor: 'streams'! flush "Signal the end of adding stream input to the receiver. Do whatever the receiver needs to get done. " self changed: #end! next "Answer the next object in the content of the receiver." self subclassResponsibility! nextPut: aHyperComponent ^self subclassResponsibility! ! !HyperComponent methodsFor: 'initialize-release'! initialize self attributes: OrderedCollection new. self anchors: OrderedCollection new. presentations := OrderedCollection new.! ! !HyperComponent methodsFor: 'accessing'! addAnchor: anAnchor self anchors add: anAnchor! addAttribute: anAttribute attributes add: anAttribute! container: anObject "anObject points to me. My subclass may want to remember that."! content ^content! content: anObject content := anObject! findAttribute: aSymbol ^attributes detect: [:each | each isAttributeName: aSymbol] ifNone: nil! formatPolicy ^formatPolicy! formatPolicy: aRenderPolicy aRenderPolicy component: self. formatPolicy := aRenderPolicy! lastAttribute ^attributes last! type ^type! type: aSymbol type := aSymbol! ! !HyperComponent methodsFor: 'refactorings'! anchors ^anchors! anchors: aValue ^anchors := aValue! attributes ^attributes! attributes: aValue ^attributes := aValue! ! !HyperComponent methodsFor: 'printing'! printOn: aStream aStream nextPutAll: '(', self class printString, type printString. aStream nextPutAll: ')'; cr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HyperComponent class instanceVariableNames: ''! !HyperComponent class methodsFor: 'instance-creation'! new ^super new initialize! ! HyperComponent subclass: #HyperLink instanceVariableNames: 'protocol ' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! HyperLink comment: 'I am an abstract class different types of links in hypertext applications. WWW application use UrlLink. Other hypertext applications may use different types of link to link differnet hypertext documents. I have a default protocol which is used to access the destination HyperComponent. Instance Variables: protocol '! !HyperLink methodsFor: 'private'! getProtocol ^self subclassResponsibility! ! !HyperLink methodsFor: 'accessing'! getStream "Executes the default protocol of this link and return a stream." ^self getStreamBy: self getProtocol! getStreamBy: aProtocol "Executes the default protocol of this link and put the result into aStream." ^aProtocol executes! linkRelativeBy: aString "Return a new instance of HypertextLink relative to the receiver by aString." ^self subclassResponsibility! protocol protocol isNil ifTrue: [protocol := self defaultProtocol]. ^protocol! protocolType "Return a symbol of the type of protocol which is used by an AccessManager to determine a protocol to use if it wants to substitute the one in the link by another protocol." ^self subclassResponsibility! request ^self subclassResponsibility! ! !HyperLink methodsFor: 'comparing'! = aHypertextLink ^self subclassResponsibility! ! HyperComponent subclass: #WebComponent instanceVariableNames: 'hTextFlag container ' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! WebComponent comment: 'WebComposite and I are parse tree nodes for HTML document. I am an atomic node. instance variables: hTextFlag True means I am a text that can be concatenated to other WebComponent for presentation. container My parent node in the parse tree.'! !WebComponent methodsFor: 'testing'! isAnchor ^false! isComposite ^false! isDestAnchor ^false! isHText ^hTextFlag! ! !WebComponent methodsFor: 'accessing'! container ^container! container: aHyperComponent container := aHyperComponent! hTextFlag: aBoolean hTextFlag := aBoolean! ! !WebComponent methodsFor: 'printing'! printFormatPolicy: aStream aStream nextPutAll: '(FormatPolicy ='. formatPolicy isNil ifFalse: [aStream nextPutAll: formatPolicy printString; cr]. aStream nextPutAll: type printString. aStream nextPutAll: ')'! ! !WebComponent methodsFor: 'enumerating'! preorderDo: aBlock aBlock value: self.! ! HyperComponent subclass: #HyperComposite instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! HyperComposite comment: 'I represent a composite hypertext component. My content is an OrderedCollection of HyperComponents.'! !HyperComposite methodsFor: 'accessing'! add: aHyperComponent content add: aHyperComponent. aHyperComponent container: self! ! !HyperComposite methodsFor: 'streams'! nextPut: aHyperComponent self add: aHyperComponent. self changed: #add with: aHyperComponent.! ! !HyperComposite methodsFor: 'initialize-release'! initialize super initialize. content := OrderedCollection new.! ! HyperComposite subclass: #WebComposite instanceVariableNames: 'hTextFlag container ' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! WebComposite comment: 'WebComponent and I are parse tree nodes for HTML document. I am a composite node. instance variables: hTextFlag True means I am a text that can be concatenated to other WebComponent for presentation. container My parent node in the parse tree.'! !WebComposite methodsFor: 'printing'! printFormatPolicy: aStream aStream nextPutAll: '(FormatPolicy ='. formatPolicy isNil ifFalse: [aStream nextPutAll: formatPolicy printString; cr]. aStream nextPutAll: type printString. aStream nextPutAll: ')'! ! !WebComposite methodsFor: 'accessing'! container ^container! container: aHyperComponent container := aHyperComponent! hTextFlag: aBoolean hTextFlag := aBoolean! ! !WebComposite methodsFor: 'testing'! isAnchor ^self type = #a! isComposite ^true! isDestAnchor ^false! isHText ^hTextFlag! ! !WebComposite methodsFor: 'enumerating'! preorderDo: aBlock aBlock value: self. content do: [:each | each preorderDo: aBlock]! ! WebComposite subclass: #LazyComposite instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Hypertext-Storage Layer'! LazyComposite comment: 'I am similar to WebComposite except when I add a new child, I don''t modify its container to me. Also, when I am used to generate HTML document, I won''t generate my type. '! !LazyComposite methodsFor: 'accessing'! add: aHyperComponent content add: aHyperComponent. self container: aHyperComponent container.! ! Object subclass: #RenderPolicy instanceVariableNames: 'maxWidth leftOffset maxWidthFlag component infoString renderer ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! RenderPolicy comment: 'I am responsibile for how a HyperComponent looks like on the screen. I assume that I will have certain types of object as my component. In other words, different kinds of component may have different format managers. For example, ListPolicy is used to format HyperComponent with type #UL. Instance Variables: maxWidth The maximum width for displaying a hypertextComponent. leftOffset indent width. maxWidthFlag Should I display the hypertextComponent with width = maxWidth? component that I am going to format. infoString misc. information that links the a hypertextComponent with its visual appearance. presentationMgr '! !RenderPolicy methodsFor: 'testing'! isAllText ^false! isHText "Return true if all the visual representations of the component are htext. All textual components that can be displayed in the same paragraph. " ^component isHText! isText ^false! ! !RenderPolicy methodsFor: 'accessing'! component ^component! component: aHypertextComponent component := aHypertextComponent! componentString ^self subclassResponsibility! embeddedFileLocation "The receiver's component may point to an embedded file, such as SRC in HTImage. Return the value of the location of this embedded file." ^nil! filename: aFilename "The receiver may need a tmpFile to save big data. "! flatten: aBoolean! formatInto: aContainer "Format component and put its visual representations (VisualLink) into aContainer. Return the last visualComponent put by me into aContainer." ^nil! ignoreCR: aBoolean! leftOffset: anInteger leftOffset := anInteger! makeTaggedString "Return a text where different characters are tagged by the HypertextComponents they represent." ^self subclassResponsibility! maxWidth: anInteger maxWidth := anInteger! maxWidthFlag ^maxWidthFlag! maxWidthFlag: aBoolean maxWidthFlag := aBoolean! presentationManager ^renderer! presentationMgr: aPresentationManager renderer := aPresentationManager! visibleComponents ^OrderedCollection new! visualComponent: aVisualComponent! visualLink ^infoString! ! !RenderPolicy methodsFor: 'private'! allFormatManagersFor: aHTObject "Return all the format managers from aHTObject and its descendants." | fmCollection | fmCollection := OrderedCollection new. aHTObject preorderDo: [:each | fmCollection add: each formatPolicy]. ^fmCollection! defaultCompositeLink ^CompositeLink new! defaultTextLink ^StructuredTextLink new! defaultVisualLink ^VisualLink new! getEmptyBlockWithHeight: height width: width | ctext vLink | ctext := ComposedText withText: ' ' asText style: nil compositionWidth: width. ctext compositionWidth: width; setHeight: height. vLink := self makeVisualLink: nil visualComponent: ctext. ^self wrapperClass on: vLink! getEmptyBlockWithHeight: height width: width component: anObject | ctext vLink | ctext := ComposedText withText: ' ' asText style: nil compositionWidth: width. ctext compositionWidth: width; setHeight: height. vLink := self makeVisualLink: anObject visualComponent: ctext. ^self wrapperClass on: vLink! leftOffset ^leftOffset! makeCompositeLink: anObject visualComponent: aVisualComponent ^(self defaultCompositeLink) structuralComponent: anObject; visualComponent: aVisualComponent! makeVisualLink: anObject visualComponent: aVisualComponent ^(self defaultVisualLink) structuralComponent: anObject; visualComponent: aVisualComponent! maxWidth ^maxWidth! ! !RenderPolicy methodsFor: 'private-wrappers'! defaultCompositePart ^(RecursiveComposite new) spaceBetweenItems: 0; leftSpace: 0! wrapperClass ^BoundedWrapper! ! RenderPolicy subclass: #TagPolicy instanceVariableNames: 'hTextFlag ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! TagPolicy comment: 'I format HTTag in general. Currently, I only display a horizontal line for HTTag objects with tag = ''HR''. I do have plans for other tags though... later..'! !TagPolicy methodsFor: 'accessing'! formatInto: aContainer | line vLink vComp | component type == #hr ifTrue: [line := HorizontalLine new width: maxWidth. vLink := self makeVisualLink: component visualComponent: line. vComp := self wrapperClass on: vLink. aContainer addWrapper: vComp. ^vComp]. ^nil! hTextFlag: aBoolean hTextFlag := aBoolean! ! RenderPolicy subclass: #ImagePolicy instanceVariableNames: 'image filename ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! ImagePolicy comment: 'I can format HTTag with tag = ''IMG''. Instance Variables: filename of the tmp file. image to be displayed.'! !ImagePolicy methodsFor: 'private'! defaultImage ^Image parcPlaceLogo! getImage "If image is cached in the instance variable, then return it. Otherwise, check if renderer has cached it. If not, then read from filename. If there is error in reading the image from the file, then return the defaultImage." image notNil ifTrue: [^image]. filename notNil ifTrue: [image := renderer visualComponentForFile: filename. image isNil ifTrue: [image := Object errorSignal handle: [:ex | self defaultImage] do: [(ImageReader fromFile: filename) image]. self changed: #builtVisualComponent with: (OrderedCollection with: filename with: image)]. ^image]. ^self defaultImage! getImageBackup "Currently, only the ParcPlace logo is returned." image notNil ifTrue: [^image]. filename notNil ifTrue: [image := renderer visualComponentForFile: filename. image isNil ifTrue: [image := Object errorSignal handle: [:ex | self defaultImage] do: [(ImageReader fromFile: filename) image]. self changed: #builtVisualComponent with: (OrderedCollection with: filename with: image)]. ^image]. ^self defaultImage! ! !ImagePolicy methodsFor: 'accessing'! embeddedFileLocation |attr| attr := component findAttribute: #src. attr notNil ifTrue: [ ^attr value]. ^nil! filename: aFilename filename := aFilename! formatInto: aContainer | vLink anImage vComponent | anImage := self getImage. vLink := (self defaultVisualLink) structuralComponent: self component; visualComponent: (CachedImage on: anImage). vComponent := self wrapperClass on: vLink. aContainer addWrapper: vComponent. ^vComponent! visualComponent: aVisualComponent image := aVisualComponent! ! RenderPolicy subclass: #TextPolicy instanceVariableNames: 'ignoreCRFlag ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! TextPolicy comment: 'I format HTText object. instance variable: ignoreCRFlag Remove all the crlf characters in the text when I format. '! !TextPolicy methodsFor: 'initialize-release'! initialize ignoreCRFlag := false! ! !TextPolicy methodsFor: 'accessing'! componentString ^component content! formatInto: aContainer | cText t vLink vComp | t := component text. ignoreCRFlag ifTrue: [t replaceAll: Character lf with: Character space. t replaceAll: Character cr with: Character space]. cText := ComposedText new compositionWidth: maxWidth text: t style: nil fitWidth: true. vLink := self makeVisualLink: component visualComponent: cText. vComp := self wrapperClass on: vLink. aContainer addWrapper: vComp. ^vComp! ignoreCR: aBoolean ignoreCRFlag := aBoolean! makeTaggedString |st| st := StructuredText fromString: self componentString. st ignoreCR: ignoreCRFlag. ^st! ! !TextPolicy methodsFor: 'testing'! isAllText ^true! isHText ^true! isText ^true! ! !TextPolicy methodsFor: 'private'! defaultVisualLink ^StructuredTextLink new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextPolicy class instanceVariableNames: ''! !TextPolicy class methodsFor: 'instance creation'! new ^super new initialize! ! RenderPolicy subclass: #ParagraphPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! ParagraphPolicy comment: 'I can format HTTag with tag = ''P''. '! !ParagraphPolicy methodsFor: 'accessing'! formatInto: aContainer | vComp | vComp := self wrapperClass on: (self getEmptyBlockWithHeight: 25 width: self maxWidth component: component). aContainer addWrapper: vComp. ^vComp! ! RenderPolicy subclass: #CompositePolicy instanceVariableNames: 'flattenFlag ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! CompositePolicy comment: 'I render HyperComposites. instance variables: flattenFlag true -> format each child individually. false -> format all the children together.'! !CompositePolicy methodsFor: 'private'! composeTaggedString: anInfoString into: aContainer width: anInteger | style cText vLink vComp | self putInfoTo: anInfoString. style := renderer styleFor: component type. cText := ComposedText withText: anInfoString style: style compositionWidth: anInteger. vLink := (self defaultTextLink) structuralComponent: component; visualComponent: cText; infoString: anInfoString. vComp := self wrapperClass on: vLink. aContainer addWrapper: vComp. ^vComp! composeText: aText style: aTextStyle into: aContainer "Make a composedText and put it into aContainer. Return the composedText." | cText vLink| cText := ComposedText withText: aText style: aTextStyle compositionWidth: maxWidth. vLink := self defaultVisualLink structuralComponent: component; visualComponent: cText. aContainer addWrapper: (self wrapperClass on: vLink). ^vLink! defaultTaggedString ^StructuredText! defaultVisualLink ^StructuredTextLink new! flatten ^flattenFlag! formatCollection: aCollection into: aContainer width: anInteger "Format each element in a collection of HypertextComponents. #isHText checks if the representations of consecutive HyperComponents may be combined into one paragraph. " | iString textWidth vComp | iString := self defaultTaggedString new. textWidth := anInteger. aCollection do: [:each | | fm | fm := each formatPolicy. (fm isHText and: [fm isText]) ifTrue: [iString := iString , fm makeTaggedString] ifFalse: [iString size > 0 ifTrue: [self composeTaggedString: iString into: aContainer width: textWidth]. textWidth := anInteger. fm maxWidth: textWidth; maxWidthFlag: false. vComp := fm formatInto: aContainer. vComp notNil ifTrue: [textWidth := textWidth - vComp preferredBounds width. textWidth < 1 ifTrue: [textWidth := anInteger]]. iString := self defaultTaggedString new]]. iString size > 0 ifTrue: [vComp := self composeTaggedString: iString into: aContainer width: textWidth]. ^vComp! putInfoTo: anInfoString | emphasis | emphasis := renderer emphasisFor: component. anInfoString addEmphasis: (OrderedCollection with: emphasis) removeEmphasis: #() allowDuplicates: true. anInfoString addStructure: (OrderedCollection with: component) removeStructure: #() allowDuplicates: true! ! !CompositePolicy methodsFor: 'accessing'! componentString "Return the string representation of the elements in the content of my component." | writeStream | self isAllText ifFalse: [^self error: 'FMComposite has non-textual components.']. writeStream := (String new: 100) writeStream. component content do: [:each | | tmpStr | tmpStr := each formatPolicy componentString. tmpStr notNil ifTrue: [writeStream nextPutAll: tmpStr]]. ^writeStream contents! flatten: aBoolean flattenFlag := aBoolean! formatInto: aContainer | vComp | self flatten ifTrue: [self eachComponentFormatPolicyDo: [:fm | fm isText ifTrue: [fm flatten: false]. vComp := fm formatInto: aContainer]. ^vComp] ifFalse: [^self formatCollection: component content into: aContainer width: maxWidth]! ignoreCR: aBoolean! makeTaggedString "Return a text where different characters are tagged by the HypertextComponents they represent." | iString | " self isAllText ifFalse: [^self error: 'FMComposite has non-textual components.']." iString := self defaultTaggedString new. component content do: [:each | | tmpInfoStr | tmpInfoStr := each formatPolicy makeTaggedString. iString := iString , tmpInfoStr]. self putInfoTo: iString. ^iString! ! !CompositePolicy methodsFor: 'initialize-release'! initialize self flatten: false! ! !CompositePolicy methodsFor: 'testing'! isAllText "Return true if all the visual representations of the components are text." | allText | allText := true. component content do: [:each | each formatPolicy isText ifFalse: [allText := false]]. ^allText! isText "Return true if all the visual representations of the components are text." | allText | allText := true. component content do: [:each | each formatPolicy isText ifFalse: [allText := false]]. ^allText! ! !CompositePolicy methodsFor: 'enumerating'! eachComponentFormatPolicyDo: aBlock component content do: [:each | | fm | fm := each formatPolicy. aBlock value: fm]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompositePolicy class instanceVariableNames: ''! !CompositePolicy class methodsFor: 'instance creation'! new ^super new initialize! ! CompositePolicy subclass: #PreFormatPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! PreFormatPolicy comment: 'I can format HTComposite objects with tag = ''CODE'', ''LISTING'', ''PLAINTEXT'', ''PRE'', ''XMP''. I tend to keep all the crlf in the component. '! !PreFormatPolicy methodsFor: 'accessing'! formatInto: aContainer self eachComponentFormatPolicyDo: [:fm | fm ignoreCR: false]. ^super formatInto: aContainer! ! CompositePolicy subclass: #ListPolicy instanceVariableNames: 'indentWidth ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! ListPolicy comment: 'I can format HTComposite object with tag = ''DIR'', ''MENU'', ''OL'', ''UL''. instance variables: indentWidth '! !ListPolicy methodsFor: 'private'! defaultFirstIndentWidth ^30! defaultVisualLink ^VisualLink new! getIndentWithHeight: anInteger ^self getEmptyBlockWithHeight: anInteger width: self indentWidth! ! !ListPolicy methodsFor: 'initialize-release'! initialize indentWidth := self defaultFirstIndentWidth! ! !ListPolicy methodsFor: 'accessing'! formatInto: aContainer | compositePart componentHeight componentWidth vLink vComp | compositePart := self defaultCompositePart. componentWidth := self maxWidth - self indentWidth. self formatCollection: component content into: compositePart width: componentWidth. componentHeight := compositePart bounds height. aContainer addWrapper: (self getIndentWithHeight: componentHeight). vLink := self makeCompositeLink: component visualComponent: compositePart. vComp := (self wrapperClass on: vLink). aContainer addWrapper: vComp. ^vComp! indentWidth ^indentWidth! indentWidth: anInteger indentWidth := anInteger! presentationManager ^renderer! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ListPolicy class instanceVariableNames: ''! !ListPolicy class methodsFor: 'instance creation'! new ^super new initialize! ! ListPolicy subclass: #DefListPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering Policies'! DefListPolicy comment: 'FMDefList objects are used to format HTComposite objects with tag = ''DL''. The instance variable component has the pair term and definition alternately. In other words, the first element in component is the first term, the second element the first definition, the third element the second term... '! !DefListPolicy methodsFor: 'accessing'! formatInto: aContainer "note: term without a definition is allowed..." | defWidth vComp | defWidth := maxWidth - self defaultSpaceAfterTerm. component content do: [:child | | termCollection defCollection ddIdx htCompChildren | htCompChildren := child content. ddIdx := htCompChildren findFirst: [:each | each type = #dd]. ddIdx > 0 ifTrue: [termCollection := htCompChildren copyFrom: 1 to: ddIdx - 1. defCollection := htCompChildren copyFrom: ddIdx to: htCompChildren size] ifFalse: [termCollection := htCompChildren. defCollection := OrderedCollection new]. self formatCollection: termCollection into: aContainer width: maxWidth. defCollection isEmpty ifFalse: [vComp := self getEmptyBlockWithHeight: 10 width: self defaultSpaceAfterTerm. aContainer addWrapper: vComp. vComp := self formatCollection: defCollection into: aContainer width: defWidth]]. ^vComp! ! !DefListPolicy methodsFor: 'private'! defaultSpaceAfterTerm ^15! defaultTermWidth ^150! defaultVisualLink ^StructuredTextLink new! ! Object subclass: #StyleSheet instanceVariableNames: 'emphasisTable styleTable defaultStyle ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering'! StyleSheet comment: 'I am an abstract class for different style sheet which provide text styles and emphasis for given a symbol.'! !StyleSheet methodsFor: 'accessing'! at: aSymbol emphasis: anEmphasis emphasisTable at: aSymbol put: anEmphasis! at: aSymbol emphasis: anEmphasis style: aTextStyle anEmphasis notNil ifTrue: [ self at: aSymbol emphasis: anEmphasis]. aTextStyle notNil ifTrue: [self at: aSymbol style: aTextStyle]! at: aSymbol style: aTextStyle ^styleTable at: aSymbol style: aTextStyle! defaultStyle ^defaultStyle! defaultStyle: aSymbol defaultStyle := aSymbol! emphasisFor: aSymbol |emphasis| emphasis := emphasisTable at: aSymbol ifAbsent: nil. " emphasis isNil ifTrue: [emphasis := self class emphasisFor: aSymbol]." ^emphasis! styleFor: aSymbol |style| style := styleTable at: aSymbol ifAbsent: nil. "style isNil ifTrue: [style := self class styleFor: aSymbol]." style isNil ifTrue: [style := self defaultStyle]. ^TextAttributes styleNamed: style! ! !StyleSheet methodsFor: 'initialize-release'! initialize styleTable := Dictionary new. emphasisTable := Dictionary new.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StyleSheet class instanceVariableNames: ''! !StyleSheet class methodsFor: 'instance creation'! defaultStyle: aSymbol ^super new initialize defaultStyle: aSymbol! new ^self error: self class printString, ' is created by #defaultStyle:'! ! Wrapper subclass: #VisualLink instanceVariableNames: 'structuralComponent ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering'! VisualLink comment: 'I consist of two components -- the structural component and the visual component. The visual component is responsible for the visual appearance of a VisualLink. The Structural component contains information about a VisualLink. This information can be nil or anything such as a node in the parse tree or a String. Several methods of VisualLinks are frequently used by LinkResolvers and Controllers: #visualComponent, #structuralComponent, #structualComponent:at:, #allStructuralComponents:at:. Instance Variables: structuralComponent '! !VisualLink methodsFor: 'hit detection'! hitDetect: t1 " ***This is decompiled code.*** This may reflect a problem with the configuration of your image and its sources and changes files. Please refer to the documentation and the settings tool for help in setting up the proper source code files." | t2 | (t2 := visualComponent hitDetect: t1) notNil ifTrue: [^self]. ^nil! ! !VisualLink methodsFor: 'accessing'! allStructuralComponents ^OrderedCollection with: self structuralComponent! allStructuralComponentsAt: aPoint "Return the structural component(s) at aPoint in a Collection. " ^self allStructuralComponents! charAt: aPoint ^Character space! componentAt: aPoint "Return the structural component at that point. " ^nil! getVisualLinkFor: aVisualComponent at: aPoint! size ^self subclassResponsibility! structuralComponent ^structuralComponent! structuralComponent: anObject structuralComponent := anObject! structuralComponentAt: aPoint "Return the structural component at that point. " ^self structuralComponent! textAt: aPoint ^Text new! visualComponent ^self component! visualComponent: aVisualComponent self component: aVisualComponent! ! !VisualLink methodsFor: 'private'! infoString ^nil! ! VisualLink subclass: #StructuredTextLink instanceVariableNames: 'sText ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering'! StructuredTextLink comment: 'I am a subclass of VisualLink where the structuralComponent is a StructuredText and the visualComponent is aComposedText. Instance Variables: sText '! !StructuredTextLink methodsFor: 'private'! infoString ^sText! ! !StructuredTextLink methodsFor: 'accessing'! allStructuralComponentsAt: aPoint | idx | self infoString notNil ifTrue: [idx := (component characterBlockAtPoint: aPoint) stringIndex. ^sText structuresAt: idx] ifFalse: [^self allStructuralComponents]! charAt: aPoint ^(component characterBlockAtPoint: aPoint) character! componentAt: aPoint "Return the structural component at that point. " ^nil! infoString: anInfoString sText := anInfoString! structuralComponentAt: aPoint "There may be more than one struucturalComponents at aPoint. Not sure which one is needed. Just return the first one. If other structuralComponents at that point is needed, #allStructuralComponentsAt: should be used." ^(self allStructuralComponentsAt: aPoint) first! textAt: aPoint ^component text! wordAt: aPoint ^(component characterBlockAtPoint: aPoint) printString! ! VisualLink subclass: #CompositeLink instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering'! CompositeLink comment: 'My structuralComponent is a WebComposite. I expect a RecursiveComposite as my visualComponent.'! !CompositeLink methodsFor: 'accessing'! allStructuralComponentsAt: aPoint ^OrderedCollection with: (self structuralComponentAt: aPoint)! charAt: aPoint |wrapper | wrapper := visualComponent hitDetect: aPoint. wrapper notNil ifTrue: [|localPoint| localPoint := aPoint translatedBy: wrapper translation negated. ^(wrapper component) charAt: localPoint]. ^super charAt: aPoint! structuralComponentAt: aPoint |wrapper | wrapper := component hitDetect: aPoint. wrapper notNil ifTrue: [|localPoint| localPoint := aPoint translatedBy: wrapper translation negated. ^(wrapper component) structuralComponentAt: localPoint]. ^super structuralComponentAt: aPoint! textAt: aPoint |wrapper | wrapper := visualComponent hitDetect: aPoint. wrapper notNil ifTrue: [|localPoint| localPoint := aPoint translatedBy: wrapper translation negated. ^(wrapper component) textAt: localPoint]. ^super textAt: aPoint! ! Model subclass: #HyperRenderer instanceVariableNames: 'model view styleMgr pageFullFlag buffer inputStream ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Rendering'! HyperRenderer comment: 'HyperRenderer presents the content of HyperComponent to the user. HyperRenderer accepts, as input, a stream of HyperComponents, such as a stream of WebComponents generated by parsing a html document. Then, it assigns a RenderPolicy to each of these components. For example, in the parse tree a HTML document, the WebComponent that represents the end paragraph tag P was assigned a ParagraphPolicy. The RenderPolicy is a Strategyobject which constructs the visual representations of the HyperComponent in terms of VisualLinks. The resuling VisualLink is wrapped by BoundedWrapper and were then put into HyperView. Instance Variables: model view styleMgr pageFullFlag buffer '! !HyperRenderer methodsFor: 'format policies'! emphasisFor: aHypertextComponent | type href | aHypertextComponent isAnchor ifTrue: [href := aHypertextComponent findAttribute: #href. href isNil ifTrue: [^nil]]. type := aHypertextComponent type. ^styleMgr emphasisFor: type! styleFor: aSymbol ^styleMgr styleFor: aSymbol! ! !HyperRenderer methodsFor: 'private'! defaultCompositeComponent | c | c := LazyComposite new type: #text. self initFormatPolicy: CompositePolicy new for: c. ^c! defaultParser ^HtmlParser new! defaultPolicySymbol ^#CompositePolicy! defaultStyleManager ^model class defaultStyleSheet! flush self formatComponentsInBuffer. view flush! formatComponent: aHypertextComponent | fm oFlag newFlag | fm := aHypertextComponent formatPolicy. fm flatten: false. oFlag := pageFullFlag. fm formatInto: view. oFlag ifTrue: [^self]. newFlag := self checkFirstPageFull. (newFlag and: [(oFlag = newFlag) not]) ifTrue: [view invalidateRectangle: view bounds repairNow: true]! formatComponentsInBuffer | c | buffer isEmpty ifTrue: [^self]. c := self defaultCompositeComponent. buffer do: [:each | c add: each]. self formatComponent: c. self initBuffer! formatManagerMap ^self class formatManagerMap! getEmbeddedNode: fm | loc link vc | loc := fm embeddedFileLocation. loc isNil ifTrue: [^self]. (UrlLink isUrlString: loc) ifTrue: [link := UrlLink urlString: loc] ifFalse: [link := model currentLink linkRelativeBy: loc]. vc := model cacheVisualComponentFor: link. vc isNil ifTrue: [fm filename: (model retrieve: link)] ifFalse: [fm visualComponent: vc]! initFormatPolicy: aFormatPolicy for: aHypertextComponent aHypertextComponent formatPolicy: aFormatPolicy. aFormatPolicy maxWidthFlag: true; presentationMgr: self; maxWidth: view bounds width! newComponent: aHypertextComponent "Check if this HypertextComponent is a HText, i.e. text that is displayed in the same paragraph with other HypertextComponents. If it is a HText, save the components in a buffer first. If not, format all the components in the buffer in the same paragraph, and then format aHypertextComponent." | fm | self initFormatPolicy: aHypertextComponent. (self isComponentVisible: aHypertextComponent) ifTrue: [fm := aHypertextComponent formatPolicy. fm isHText ifTrue: [buffer add: aHypertextComponent] ifFalse: [self formatComponentsInBuffer. self formatComponent: aHypertextComponent]]! ! !HyperRenderer methodsFor: 'updating'! update: aSymbol with: anObject " aSymbol == #add ifTrue: [^self newComponent: anObject]. aSymbol == #end ifTrue: [^self flush]. aSymbol == #start ifTrue: [^self initialize]." aSymbol == #builtVisualComponent ifTrue: [^self changed: #builtVisualComponent with: anObject]! ! !HyperRenderer methodsFor: 'testing'! checkFirstPageFull | winBottom | pageFullFlag ifTrue: [^pageFullFlag]. view components isEmpty ifTrue: [^false]. winBottom := view bounds bottom. pageFullFlag := view components last bounds bottom > winBottom. ^pageFullFlag! isComponentVisible: aHTComponent | type | type := aHTComponent type. ^(type = #head or: [type = #title]) not! optimize ^true! ! !HyperRenderer methodsFor: 'accessing'! command ^model command! inputStream: aStream inputStream := aStream. self initialize. [inputStream atEnd] whileFalse: [| tmp | tmp := inputStream next. tmp isNil ifFalse: [self newComponent: tmp]]. self flush. inputStream close! model: aModel model := aModel! open | window | window := ApplicationWindow model: self label: 'NetBrowser' minimumSize: 400 @ 350. view := HyperView new model: self. window component: (LookPreferences edgeDecorator on: view). window open. view bounds: (0 @ 0 extent: window extent). self view: view! optimize: aBoolean! policyFor: aSymbol "Search the formatManagerMap for a FormatManager for this symbol. If aSymbol is not found in the formatManagerMap, then a defaultFormatManager is given. If the formatManager in a visitor pattern is finished, then this method just return a defaultFormatManager. This saves a lot of time..." | class | class := self formatManagerMap at: aSymbol ifAbsent: [self defaultPolicySymbol]. ^(Smalltalk at: class) new! styleSheet: aStyleSheet styleMgr := aStyleSheet! view ^view! view: aView view := aView! visualComponentForFile: aFilename ^model visualComponentForFile: aFilename! ! !HyperRenderer methodsFor: 'initialize-release'! initBuffer buffer := OrderedCollection new! initFormatPolicy: aHypertextComponent "Initialize FormatManagers for aHypertextComponent and its descendants." aHypertextComponent preorderDo: [:each | | fm | fm := self policyFor: each type. "fm addDependent: self." each formatPolicy: fm. self getEmbeddedNode: fm. fm maxWidthFlag: true; presentationMgr: self; maxWidth: view bounds width]! initForRedraw pageFullFlag := false. view notNil ifTrue: [view initialize].! initialize self initForRedraw. self initStyleManager. pageFullFlag := false. self initBuffer.! initStyleManager styleMgr isNil ifTrue: [ styleMgr := self defaultStyleManager]! release super release. inputStream release! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HyperRenderer class instanceVariableNames: 'FormatManagerMap '! !HyperRenderer class methodsFor: 'accessing'! formatManagerMap ^FormatManagerMap! ! !HyperRenderer class methodsFor: 'class initialization'! initialize "self initialize" FormatManagerMap := Dictionary new. (#(#(#base #RenderPolicy ) #(#br #TagPolicy ) #(#code #PreFormatPolicy ) #(#comment #RenderPolicy ) #(#dir #ListPolicy ) #(#dl #DefListPolicy ) #(#head #RenderPolicy ) #(#hr #TagPolicy ) #(#img #ImagePolicy ) #(#input #RenderPolicy) #(#isindex #RenderPolicy ) #(#listing #PreFormatPolicy ) #(#menu #ListPolicy ) #(#nextid #RenderPolicy ) #(#ol #ListPolicy ) #(#option #RenderPolicy ) #(#p #ParagraphPolicy ) #(#plaintext #PreFormatPolicy ) #(#pre #PreFormatPolicy ) #(#text #TextPolicy ) #(#ul #ListPolicy ) #(#xmp #PreFormatPolicy ) )) do: [:each | FormatManagerMap at: (each at: 1) put: (each at: 2)]! ! !HyperRenderer class methodsFor: 'instance-creation'! model: aHyperApp styleSheet: aStyleSheet ^super new styleSheet: aStyleSheet; model: aHyperApp; initialize! new ^super new initialize! ! HyperRenderer initialize! Object subclass: #Command instanceVariableNames: 'model ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Commands'! !Command methodsFor: 'accessing'! at: aPoint! execute ^self subclassResponsibility! model: aModel model := aModel! view: aView! ! Command subclass: #CmdClick instanceVariableNames: 'view point ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Commands'! !CmdClick methodsFor: 'accessing'! at: aPoint point := aPoint! execute | state | state := WebGUIAction new. state visualComponent: view; point: point; actionType: #click. model retrieveLink: state! view: aView view := aView! ! Object subclass: #Request instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Protocols'! Request comment: 'I have all the information needed by a Protocol. Subclass describes the exact details.'! !Request methodsFor: 'accessing'! protocol " ***This is decompiled code.*** This may reflect a problem with the configuration of your image and its sources and changes files. Please refer to the documentation and the settings tool for help in setting up the proper source code files." ^self subclassResponsibility! ! Request subclass: #HttpRequest instanceVariableNames: 'host path port search ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Protocols'! HttpRequest comment: 'HttpProtocol definitely needs my knowledge!! Instance Variables: host like st.cs.uiuc.edu path port search like ?+hello in the Url. '! !HttpRequest methodsFor: 'private'! defaultPortNumber " ***This is decompiled code.*** This may reflect a problem with the configuration of your image and its sources and changes files. Please refer to the documentation and the settings tool for help in setting up the proper source code files." ^80! ! !HttpRequest methodsFor: 'accessing'! host ^host! host: aString host := aString! path " ***This is decompiled code.*** This may reflect a problem with the configuration of your image and its sources and changes files. Please refer to the documentation and the settings tool for help in setting up the proper source code files." ^path! path: aString path := aString! port " ***This is decompiled code.*** This may reflect a problem with the configuration of your image and its sources and changes files. Please refer to the documentation and the settings tool for help in setting up the proper source code files." ^port! port: aStringOrInteger port := aStringOrInteger asNumber! protocol ^'http'! search search isNil ifTrue: [^''] ifFalse: [^search]! search: aString search := aString! ! Request subclass: #UnixFileRequest instanceVariableNames: 'path ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Protocols'! UnixFileRequest comment: 'Without me, FileProtocol cannot execute. Instance Variables: path '! !UnixFileRequest methodsFor: 'accessing'! path ^path! path: aString path := aString. path first = $/ ifFalse: [path := '/', path]! protocol ^'file'! ! Object subclass: #Protocol instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Protocols'! Protocol comment: 'I am an abstract super class for protocols that can access hypertext components. My subclass needs a Request to get the parameters for access.'! !Protocol methodsFor: 'accessing'! executes "execute this protocol and return a stream as a result." ^self subclassResponsibility! executes: aRequest "execute this protocol and return a stream as a result." ^self subclassResponsibility! ! Protocol subclass: #FileProtocol instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Protocols'! FileProtocol comment: 'I can access local files. '! !FileProtocol methodsFor: 'accessing'! executes "execute this protocol and return a stream as a result." ^self shouldNotImplement! executes: aRequest ^aRequest path asFilename readStream! ! Protocol subclass: #HttpProtocol instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Protocols'! HttpProtocol comment: 'I can access Web server. '! !HttpProtocol methodsFor: 'private'! makeRequestFrom: method port: portNumber path: path search: searchStr ^method , ' ' , path , searchStr , ' HTTP/1.0' , Character cr asString , Character lf asString! ! !HttpProtocol methodsFor: 'accessing'! executes "execute this protocol and return a stream as a result." ^self shouldNotImplement! executes: aHTTPRequest "Send a request to an http server and return the reply as a stream." | host port path socket connection outStream inStream request search | host := aHTTPRequest host. port := aHTTPRequest port. path := aHTTPRequest path. search := aHTTPRequest search. socket := SocketAccessor newTCPclientToHost: host port: port. connection := ExternalConnection new. connection input: socket; output: socket. outStream := connection writeStream. request := self makeRequestFrom: 'GET' port: port path: path search: search. outStream nextPutAll: request; commit. inStream := connection readStream binary. ^inStream! ! Object subclass: #Url instanceVariableNames: 'index ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-URL'! Url comment: 'I am an abstract super class for URLs. instance Variables: index of the form #index. '! !Url methodsFor: 'accessing'! host ^nil! host: aString! index ^index! index: aString index := aString! path ^nil! path: aString! port ^nil! port: aString! scheme "Return the scheme of a url in Symbol." ^self subclassResponsibility! search ^nil! search: aString! urlRelativeBy: aPathString "Return a new copy of the receiver and modify the path of that copy relative by aPathString." | url | url := self completeUrlString: aPathString. ^UrlBuilder new url: url! ! !Url methodsFor: 'private'! completeRelativePath: aPathString to: newUrl "Generate a new path relative to the receiver's path by aPathString. Put this new path into newUrl." | tmpPath totalDirUp startIdx dotDotIdx | aPathString first = $/ ifTrue: [tmpPath := aPathString] ifFalse: [tmpPath := self path. totalDirUp := self computeTotalDirUp: aPathString. tmpPath := self move: tmpPath upDirLevel: totalDirUp. tmpPath isEmpty ifFalse: [tmpPath last = $/ ifFalse: [tmpPath := tmpPath , '/']]. dotDotIdx := self lastDotDotIdx: aPathString. dotDotIdx = 0 ifTrue: [startIdx := 1] ifFalse: [startIdx := dotDotIdx + 2]. tmpPath := tmpPath , (aPathString copyFrom: startIdx to: aPathString size). tmpPath first = $/ ifFalse: [tmpPath := '/' , tmpPath]]. newUrl path: tmpPath! completeUrlString: aPathString "Generate a new url string relative to the receiver." | tmpPath totalDirUp startIdx dotDotIdx | aPathString first = $/ ifTrue: [tmpPath := aPathString] ifFalse: [tmpPath := self path. totalDirUp := self computeTotalDirUp: aPathString. tmpPath := self move: tmpPath upDirLevel: totalDirUp. tmpPath isEmpty ifFalse: [tmpPath last = $/ ifFalse: [tmpPath := '/']]. dotDotIdx := self lastDotDotIdx: aPathString. dotDotIdx = 0 ifTrue: [startIdx := 1] ifFalse: [startIdx := dotDotIdx + 2]. tmpPath := tmpPath , (aPathString copyFrom: startIdx to: aPathString size). tmpPath first = $/ ifFalse: [tmpPath := '/' , tmpPath]]. ^self printWithPath: tmpPath! computeTotalDirUp: aPathString "Return the total number of .. in aPathString." | total | total := 0. aPathString keysAndValuesDo: [:idx :elt | idx > 1 ifTrue: [(elt = $. and: [(aPathString at: idx - 1) = $.]) ifTrue: [total := total + 1]]]. ^total! lastDotDotIdx: aPathString "Return the start index of the last occurence of .. in aPathString." | lastDotDotIdx | lastDotDotIdx := 0. aPathString keysAndValuesDo: [:idx :elt | idx > 1 ifTrue: [(elt = $. and: [(aPathString at: idx - 1) = $.]) ifTrue: [lastDotDotIdx := idx]]]. ^lastDotDotIdx! move: aPathString upDirLevel: anInteger | slashIndexes endIdx tmpStr slashIdx | tmpStr := aPathString. slashIdx := aPathString findLast: [:each | each = $/]. slashIdx > 0 ifTrue: [tmpStr := tmpStr copyFrom: 1 to: slashIdx]. anInteger < 1 ifTrue: [^tmpStr]. slashIndexes := OrderedCollection new. tmpStr keysAndValuesDo: [:idx :elt | elt = $/ ifTrue: [slashIndexes add: idx]]. endIdx := slashIndexes at: (slashIndexes size - anInteger). ^tmpStr copyFrom: 1 to: endIdx! ! !Url methodsFor: 'printing'! printContentOn: aStream "Print the content of a url after 'scheme://'. " ^self subclassResponsibility! printOn: aStream aStream nextPutAll: self scheme, ':/'. self printContentOn: aStream! ! !Url methodsFor: 'comparing'! = aUrl ^(self printString) = aUrl printString! hash ^self printString hash! ! Url subclass: #UrlHttp instanceVariableNames: 'host path port search ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-URL'! !UrlHttp methodsFor: 'accessing'! host ^host! host: aString host := aString! path path isNil ifTrue: [path := '']. ^path! path: aString path := aString! port ^port! port: aString port := aString! scheme ^#http! search search isNil ifTrue: [search := '']. ^search! search: aString search := aString! ! !UrlHttp methodsFor: 'printing'! printContentOn: aStream aStream nextPutAll: '/' , host. port notNil ifTrue: [aStream nextPutAll: ':' , port]. self path isEmpty ifFalse: [path first = $/ ifFalse: [aStream nextPutAll: '/']. aStream nextPutAll: self path]. search notNil ifTrue: [aStream nextPutAll: self search]! printWithPath: aPathString | output | output := 'http://' , host. port notNil ifTrue: [output := output , ':' , port]. path notNil ifTrue: [output := output , aPathString]. search notNil ifTrue: [output := output , search]. ^output! ! Url subclass: #UrlFile instanceVariableNames: 'path ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-URL'! !UrlFile methodsFor: 'accessing'! path path isNil ifTrue: [path := '']. ^path! path: aString path := aString! scheme ^#file! ! !UrlFile methodsFor: 'printing'! printContentOn: aStream path notNil ifTrue: [ aStream nextPutAll: path ]! printWithPath: aPathString ^'file:/' , aPathString , self index! ! Object subclass: #UrlBuilder instanceVariableNames: 'scanner ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-URL'! UrlBuilder comment: 'I am a url parser. '! !UrlBuilder methodsFor: 'accessing'! url: aUrlString "Create a Url corresponds to the scheme in aUrlString." | tokens idx url stringWithoutPound poundIdx poundStr | tokens := scanner scanTokens: aUrlString. poundIdx := aUrlString indexOf: $# ifAbsent: 0. poundIdx = 0 ifTrue: [stringWithoutPound := aUrlString. poundStr := ''] ifFalse: [self halt. stringWithoutPound := aUrlString copyFrom: 1 to: poundIdx - 1. poundStr := aUrlString copyFrom: poundIdx to: aUrlString size]. idx := stringWithoutPound findString: ':' startingAt: 1. url := self perform: (tokens at: 1) with: (stringWithoutPound copyFrom: idx + 3 to: stringWithoutPound size). url index: poundStr. ^url! ! !UrlBuilder methodsFor: 'scheme dependent'! file: aString |aUrl| aUrl := UrlFile new. self fillPathFor: aUrl from: aString. ^aUrl! http: aNoSchemeUrlStr | startIdx idx hostportStr pathStr searchStr length aUrl | length := aNoSchemeUrlStr size. aUrl := UrlHttp new. idx := aNoSchemeUrlStr findString: '/' startingAt: 1. idx = 0 ifTrue: [hostportStr := aNoSchemeUrlStr copyFrom: 1 to: length. startIdx := length + 1] ifFalse: [hostportStr := aNoSchemeUrlStr copyFrom: 1 to: idx - 1. startIdx := idx + 1]. idx := aNoSchemeUrlStr findString: '?' startingAt: startIdx. idx > 0 ifTrue: [pathStr := aNoSchemeUrlStr copyFrom: startIdx to: idx - 1. searchStr := aNoSchemeUrlStr copyFrom: idx to: length] ifFalse: [pathStr := aNoSchemeUrlStr copyFrom: startIdx to: length]. self fillHostPortFor: aUrl from: hostportStr. self fillPathFor: aUrl from: pathStr. self fillSearchFor: aUrl from: searchStr. ^aUrl! ! !UrlBuilder methodsFor: 'initialize-release'! initialize scanner := Scanner new! ! !UrlBuilder methodsFor: 'private'! fillHostPortFor: aUrl from: aString (aString isNil or: [ aString isEmpty]) ifFalse: [ |idx| idx := aString findString: ':' startingAt: 1. idx = 0 ifTrue: [ aUrl host: aString] ifFalse: [ aUrl host: (aString copyFrom: 1 to: (idx - 1)). aUrl port: (aString copyFrom: (idx + 1) to: aString size)]]! fillPathFor: aUrl from: aString (aString isNil or: [aString isEmpty]) ifFalse: [aUrl path: aString]! fillSearchFor: aUrl from: aString (aString isNil or: [aString isEmpty]) ifFalse: [aUrl search: aString]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UrlBuilder class instanceVariableNames: ''! !UrlBuilder class methodsFor: 'instance creation'! new ^super new initialize! ! HyperLink subclass: #UrlLink instanceVariableNames: 'url request ' classVariableNames: 'UrlParser ' poolDictionaries: '' category: 'HyperTalk-Link Resolving Components'! !UrlLink methodsFor: 'comparing'! = aUrlLink ^url = (aUrlLink url)! hash ^url hash! ! !UrlLink methodsFor: 'accessing'! getStreamBy: aProtocol "Executes the default protocol of this link and put the result into aStream." ^aProtocol executes: request! linkRelativeBy: aRelativeUrlString "Return a new link with aUrlStringOrFilenameString relative to me." | newLink | newLink := self copy. newLink url: (url urlRelativeBy: aRelativeUrlString). ^newLink! protocolType ^url scheme! request ^request! url ^url! url: aUrl url := aUrl. self makeRequestFor: url scheme from: aUrl! ! !UrlLink methodsFor: 'printing'! printOn: aStream aStream nextPutAll: url printString! ! !UrlLink methodsFor: 'private'! defaultPortFor: aSymbol aSymbol == #http ifTrue: [^'80'].! defaultProtocolFor: aSymbol aSymbol == #http ifTrue: [^HttpProtocol new]. aSymbol == #file ifTrue: [^FileProtocol new]. ^nil! getProtocol ^self defaultProtocolFor: url scheme! isUrl: aString | idx | idx := aString findString: ':' startingAt: 1. ^(idx = 0) not! makeFileRequestFrom: aUrl request := UnixFileRequest new. request path: aUrl path. ^request! makeHttpRequestFrom: aHttpUrl | port path | request := HttpRequest new. port := aHttpUrl port. port isNil ifTrue: [port := self defaultPortFor: #http]. path := aHttpUrl path. (path isNil or: [path isEmpty]) ifTrue: [path := '/'] ifFalse: [path first = $/ ifFalse: [path := '/' , path]]. request host: aHttpUrl host; port: port; path: path; search: aHttpUrl search. ^request! makeRequestFor: aSymbol from: aUrl aSymbol == #http ifTrue: [^self makeHttpRequestFrom: aUrl]. aSymbol == #file ifTrue: [^self makeFileRequestFrom: aUrl]. ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UrlLink class instanceVariableNames: ''! !UrlLink class methodsFor: 'instance creation'! urlString: aString | link url | url := UrlParser url: aString. link := super new url: url. link makeRequestFor: url scheme from: url. ^link! ! !UrlLink class methodsFor: 'class initialization'! initialize "self initialize" UrlParser := UrlBuilder new! ! !UrlLink class methodsFor: 'testing'! isUrlString: aString | idx | idx := aString findString: ':' startingAt: 1. ^(idx = 0) not! ! Object subclass: #LinkResolver instanceVariableNames: 'aspectSymbol ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Link Resolving Components'! LinkResolver comment: 'I am resposible for retrieving a link from a UserActionState. If a link can be retrieved, then I will report it to a HypertextModel. Subclass decides the type of link to generate. Subclass should implement: aspectSymbol retrieveLink: instance variables: aspectSymbol If a link is found, this symbol is broadcast to the subscribers of a HypertextModel. The subscribers use this symbol to determine if the link retrieved is useful for them. automaticReport If automaticReoprt is true, everytime a new link is retrieved, the hypertextModel is notified immediately. '! !LinkResolver methodsFor: 'accessing'! aspectSymbol aspectSymbol isNil ifTrue: [^self defaultAspectSymbol]. ^aspectSymbol! aspectSymbol: aSymbol aspectSymbol := aSymbol! retrieveLink: aUserActionState for: aHyperApp "First, find the most top wrapper contained in the view at that point. The wrapper contains a VisualLink which is used to retrieve the link. The link can be a HyperLink or any other objects such as a Character." | view point wrapper link | view := aUserActionState visualComponent. point := aUserActionState point. wrapper := view hitDetect: point. wrapper notNil ifTrue: [| visualLink localPoint | visualLink := wrapper component. localPoint := point translatedBy: wrapper translation negated. link := self retrieveLink: visualLink at: localPoint. link notNil ifTrue: [aHyperApp reportLink: link aspect: self aspectSymbol]]! ! !LinkResolver methodsFor: 'updating'! update: anAspectSymbol with: aParameter from: aSender anAspectSymbol == #retrieveLink ifTrue: [ self retrieveLink: aParameter for: aSender]! ! !LinkResolver methodsFor: 'private'! defaultAspectSymbol ^self subclassResponsibility! ! LinkResolver subclass: #TextResolver instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Link Resolving Components'! TextResolver comment: 'I can retrieve the whole paragraph on a HyperView from a Point.'! !TextResolver methodsFor: 'private'! defaultAspectSymbol ^#text! retrieveLink: aVisualLink at: aPoint ^aVisualLink textAt: aPoint! ! LinkResolver subclass: #UrlResolver instanceVariableNames: 'currentLink ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Link Resolving Components'! UrlResolver comment: 'I retrieve a UrlLink. instance variables: lastLink The last link retrieved. Useful when a relative HREF is supplied instead of a URL.'! !UrlResolver methodsFor: 'private'! completeUrl: aFilenameString | currentPath idx lastChar targetChar dir request protocol address | request := currentLink request. currentPath := request path. (currentPath findString: '/' startingAt: 1) > 0 ifTrue: [targetChar := $/] ifFalse: [targetChar := $\]. lastChar := currentPath last. lastChar = targetChar ifTrue: [currentPath := currentPath copyFrom: 1 to: currentPath size - 1]. idx := currentPath lastIndexOf: targetChar. idx > 0 ifTrue: [dir := currentPath copyFrom: 1 to: idx. dir first = '/' ifFalse: [dir := '/' , dir]] ifFalse: [ dir := '/']. protocol := request protocol. address := request address. ^protocol , '://' , address , dir , aFilenameString! defaultAspectSymbol ^#url! isUrl: aString | idx | idx := aString findString: ':' startingAt: 1. ^(idx = 0) not! retrieveLink: aVisualLink at: aPoint "The hypertext component at that point is retrieved from aVisualLink. The #href attribute of that component is the key to the link. I can handle relative link such as '../hello.html' or a url such as 'http://st-www.cs.uiuc.edu'." | htComponent attribute | htComponent := (aVisualLink allStructuralComponentsAt: aPoint) detect: [:each | each isAnchor ] ifNone: nil. htComponent isNil ifTrue: [^nil]. attribute := htComponent findAttribute: #href. attribute notNil ifTrue: [|dest| dest := attribute value. (self isUrl: dest) ifFalse: [^currentLink linkRelativeBy: dest]. ^UrlLink urlString: dest]. ^nil! updateLink: aParameter currentLink := aParameter! ! !UrlResolver methodsFor: 'updating'! update: anAspectSymbol with: aParameter from: aSender super update: anAspectSymbol with: aParameter from: aSender. anAspectSymbol == #currentLink ifTrue: [ self updateLink: aParameter]! ! LinkResolver subclass: #CharResolver instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Link Resolving Components'! CharResolver comment: 'I can retrieve the character on a HyperView from a point. '! !CharResolver methodsFor: 'private'! defaultAspectSymbol ^#char! retrieveLink: aVisualLink at: aPoint ^aVisualLink charAt: aPoint! ! UrlLink initialize! Model subclass: #HyperApp instanceVariableNames: 'inputStream linkAccessor renderer currentLink resolvers document ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! HyperApp comment: 'I am an abstract class for different kinds of hypertext application models. HyperApp is the abstract super class for hypertext domain models. Its main function is to coordinate, initialize and delegate functionalities to its different components. HyperApp is a Facade object for the following components: LinkResolver LinkAccessor StreamManager StreamFilter & HyperRenderer Viewer When HyperApp is initialized, it also initializes its HyperRenderer, LinkAccessor, and StreamManager. HyperRenderer is used to create VisualComponents that represents the HyperComponent in the main window of the application. LinkAccessor is used to retrieve the destination HyperComponent specified by a HyperLink. Besides, one or more LinkResolvers are also registered as dependents of HyperApp. Subclass needs to implement the following: class methods: #initStyleSheet Instance Variables: linkAccessor inputStream renderer currentLink resolvers '! !HyperApp methodsFor: 'initialize-release'! addDefaultResolvers ^self subclassResponsibility! initialize self initRenderer. linkAccessor := self defaultLinkAccessor. resolvers := OrderedCollection new. self addDefaultResolvers.! initRenderer renderer := self defaultRenderer. renderer model: self.! initStyleSheet self subclassResponsibility! ! !HyperApp methodsFor: 'testing'! isRelevant: aSymbol "Test if this symbol specifies a link type in which the receiver is interested in." ^false! ! !HyperApp methodsFor: 'accessing'! currentLink ^currentLink! currentLink: aHyperLink currentLink := aHyperLink! jumpTo: aHypertextLink self currentLink: aHypertextLink. renderer initForRedraw. linkAccessor get: aHypertextLink.! registerLinkResolver: aLinkResolver resolvers add: aLinkResolver. self addDependent: aLinkResolver.! registerSubscriber: anObject ^self addDependent: anObject! renderer ^renderer! reportLink: anObject aspect: anAspectSymbol "The receiver first check if the link reported is relevant to itself. Then, it broadcasts the new link." (self isRelevant: anAspectSymbol) ifTrue: [self jumpTo: anObject]. self changed: anAspectSymbol with: anObject! retrieveLink: aUserActionState "Some external object (CmdClick for example) sent a request to the receiver to retreive a link after the user has done something 'meaningful'. The receiver doesn't know how to retrieve a link, so it delegates to all its LinkResolvers to do it. When the LinkResolvers can find it, it reports back to the receiver by #reportLink:aspect:. The link retrieved can be HyperLink or anything. UrlResovler returns a UrlLink. CharResolver returns a character. TextResolver returns a text. " resolvers do: [:each | each retrieveLink: aUserActionState for: self].! ! !HyperApp methodsFor: 'private'! broadcastToResolvers: anAspectSymbol with: anObject resolvers do: [:each | each update: anAspectSymbol with: anObject from: self]! defaultLinkAccessor ^self subclassResponsibility! defaultRenderer ^self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HyperApp class instanceVariableNames: 'StreamActionMap StyleMap '! !HyperApp class methodsFor: 'instance creation'! new ^super new initialize! ! !HyperApp class methodsFor: 'accessing'! defaultStyleSheet ^StyleMap! ! !HyperApp class methodsFor: 'class initialization'! initActionMap "Initialize the class instance variable StreamActionMap"! initialize "self initialize" self initActionMap. self initStyleMap! initStyleMap "Subclass may want to initialize the StyleMap by StyleMap at: emphasis: style: " StyleMap := StyleSheet defaultStyle: #htmlDefault.! ! Model subclass: #Viewer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! Viewer comment: 'Viewer is a simple abstract super class for all external viewers. Basically, it takes a file name and then spawn a new window to display that file. Currently, the only abstract subclass is ImageViewer which delegates to an ImageReader to view different image files such as gif and bitmap files.

Viewer can also acts as an adaptor for other external viewers. A concrete subclass may be a PostScriptViewer which delegates Ghostscript to display a postscript file. '! !Viewer methodsFor: 'testing'! isBinary ^self subclassResponsibility! ! !Viewer methodsFor: 'private'! configure: aBinaryStream filename: aFilename self isBinary ifTrue: [aBinaryStream binary. ^aFilename writeStream binary] ifFalse: [aBinaryStream text. ^aFilename writeStream text]! ! !Viewer methodsFor: 'accessing'! save: aBinaryStream into: aFilename "Save aBinaryStream into a temporary file." |writeStream pos| pos := aBinaryStream position. writeStream := self configure: aBinaryStream filename: aFilename. writeStream nextPutAll: aBinaryStream; close. aBinaryStream position: pos.! viewFile: aFilename "Open and display a new window that view aFilename." ^self subclassResponsibility! ! Viewer subclass: #ImageViewer instanceVariableNames: 'imageReader ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! ImageViewer comment: 'I can display an image file.'! !ImageViewer methodsFor: 'accessing'! viewFile: aFilename imageReader := ImageReader displayFromFile: aFilename! ! !ImageViewer methodsFor: 'testing'! isBinary ^true! ! Object subclass: #LinkAccessor instanceVariableNames: 'outputStream cache ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! LinkAccessor comment: 'Given a link, I probably can access the destinatio hypertext component. If a stream is returned from the access, then it can be accessed by #outputStream. '! !LinkAccessor methodsFor: 'accessing'! cache: aCache cache := aCache! get: aHyperLink | cacheFilename | cacheFilename := cache filenameAtLink: aHyperLink. cacheFilename isNil ifTrue: [outputStream := aHyperLink getStream] ifFalse: [outputStream := cacheFilename readStream]! outputStream ^outputStream! ! !LinkAccessor methodsFor: 'testing'! isLinkInCache: aHypertextLink "Check if aHypertextLink is in the cache. It depends on the subclass to implement the caching mechanism." ^false! ! ComposingComposite subclass: #RecursiveComposite instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! RecursiveComposite comment: 'RecursiveComposite overwrites the hitDetect: method of its superclass. Instead of returning an immediate child from hiDetect:, RecursiveComposite return the youngest generation child(leaf). '! !RecursiveComposite methodsFor: 'hit detection'! hitDetect: aPoint "Answer a component that contains point aPoint or nil. The component may be a component of a component, a comopnent of a component of a component..." |c| c := super hitDetect: aPoint. c notNil ifTrue: [ ^c hitDetect: aPoint]. ^c! ! Object subclass: #ActionEntry instanceVariableNames: 'filter viewer subtypeActionMap ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! ActionEntry comment: 'I am the entry of the dictionary in ActionMap. Instance Variables: type of a type. filter of the class name of a StreamFilter. viewer of the class name of a viewer. subtypeActionMap of a subtype. '! !ActionEntry methodsFor: 'accessing'! filter ^filter! filter: aSymbol filter := aSymbol! subtypeActionMap ^subtypeActionMap! subtypeActionMap: anActionMap subtypeActionMap := anActionMap! viewer ^viewer! viewer: aSymbol viewer := aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActionEntry class instanceVariableNames: ''! !ActionEntry class methodsFor: 'instance creation'! filter: aFilterClassSymbol viewer: aViewerClassSymbol subtypeActionMap: anActionMap | entry | entry := super new. entry filter: aFilterClassSymbol; viewer: aViewerClassSymbol; subtypeActionMap: anActionMap. ^entry! ! PositionableStream subclass: #PositionableTStream instanceVariableNames: 'inputStream outputStream posOffset atEnd ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! !PositionableTStream methodsFor: 'positioning'! setToEnd outputStream nextPutAll: inputStream! skip: anInteger inputStream skip: anInteger. anInteger > 0 ifTrue: [ anInteger timesRepeat: [ outputStream nextPut: inputStream next] ] ifFalse: [ posOffset := anInteger ].! ! !PositionableTStream methodsFor: 'accessing'! close inputStream close. outputStream close.! inputStream ^inputStream! inputStream: anInputStream outputStream: anOutputStream inputStream := anInputStream. outputStream := anOutputStream. atEnd := anInputStream atEnd! next | t | t := inputStream next. t isNil ifTrue: [ atEnd := true] ifFalse: [posOffset < 0 ifTrue: [posOffset := posOffset + 1] ifFalse: [outputStream nextPut: t]]. ^t! text ^inputStream text! ! !PositionableTStream methodsFor: 'initialize-release'! initialize posOffset := 0. atEnd := true! ! !PositionableTStream methodsFor: 'testing'! atEnd ^atEnd | inputStream atEnd! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PositionableTStream class instanceVariableNames: ''! !PositionableTStream class methodsFor: 'instance creation'! on: inputStream to: outputStream ^self basicNew initialize inputStream: inputStream outputStream: outputStream! ! RecursiveComposite subclass: #HyperView instanceVariableNames: 'model controller ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! !HyperView methodsFor: 'control'! objectWantingControlbackup components == nil ifFalse: [^self]. ^nil! ! !HyperView methodsFor: 'model access'! model ^model! model: aModel (model notNil and: [model ~~ aModel]) ifTrue: [model removeDependent: self]. (aModel notNil and: [aModel ~~ model]) ifTrue: [aModel addDependent: self]. model := aModel! ! !HyperView methodsFor: 'controller accessing'! controller ^controller! controller: aController self setController: aController! defaultController ^self defaultControllerClass new! ! !HyperView methodsFor: 'initialize-release'! initializeSpacing super initializeSpacing. leftSpace := 0. extraSpaceTop := 5. spaceBetweenItems := 0! ! !HyperView methodsFor: 'private'! defaultControllerClass ^WebController! getController controller == nil ifTrue: [self setController: self defaultController]. ^controller! setController: aController "Set the receiver's controller to aController. If aController is not nil, its view is set to the receiver and its model is set to aModel." aController == nil ifFalse: [aController view: self. aController model: model]. controller := aController! ! !HyperView methodsFor: 'accessing'! componentAt: aPoint ^self hitDetect: aPoint! flush self layoutComponentsForBounds: self bounds. self repairDamage! ! !HyperView methodsFor: 'updating'! update: t1 with: t2 t1 == #resize ifTrue: [self processResize]. t1 == #startFilling ifTrue: [self initialize. ^self endFilling: false]. t1 == #endFilling ifTrue: [^self flush]. t1 == #newPM ifTrue: [ t2 view: self ].! ! Stream subclass: #StreamFilter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! StreamFilter comment: 'I am an abstract class who works with StreamManager to parse inputStream. I may need to broadcast to my dependents of what I have built. If there is an outputStream, remember to flush the outputStream when you are done. '! !StreamFilter methodsFor: 'accessing'! inputStream: aStream "self subclassResponsibility"! outputStream "Return the outputStream. If my subclass wants to spawn another process instead of passing the outputStream for someone else, then returns nil."! outputStream: aStream "self subclassResponsibility"! save: aBinaryStream into: aFilename "Save aBinaryStream into a temporary file." |writeStream pos| writeStream := self configure: aBinaryStream filename: aFilename. pos := aBinaryStream position. writeStream nextPutAll: aBinaryStream; close. aBinaryStream position: pos.! tmpFilename: aFilename "Some of my subclasses may need to save the inputStream as a tmpFile. This method provides a tmp Filename. "! ! !StreamFilter methodsFor: 'testing'! needTmpFile ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StreamFilter class instanceVariableNames: ''! !StreamFilter class methodsFor: 'instance creation'! new ^self basicNew! ! StreamFilter subclass: #PlainTextFilter instanceVariableNames: 'outputStream inputStream ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! !PlainTextFilter methodsFor: 'accessing'! close inputStream close! inputStream: aBinaryStream " | hComp tmpStream | tmpStream := ReadWriteStream on: (String new: 1000). [aBinaryStream atEnd] whileFalse: [tmpStream nextPut: aBinaryStream next]. aBinaryStream close. hComp := WebComponent new hTextFlag: false; type: #text. hComp content: tmpStream contents. outputStream nextPut: hComp. outputStream flush" inputStream := aBinaryStream! needTmpFile ^false! next | tmpStream | tmpStream := ReadWriteStream on: (String new: 1000). [inputStream atEnd] whileFalse: [tmpStream nextPut: inputStream next]. ^WebComponent new hTextFlag: false; type: #text; content: tmpStream contents.! outputStream outputStream isNil ifTrue: [ outputStream := self defaultOutputStream]. ^outputStream! outputStream: aStream outputStream := aStream! ! !PlainTextFilter methodsFor: 'testing'! atEnd ^inputStream atEnd! isBinary ^false! ! !PlainTextFilter methodsFor: 'private'! configure: aBinaryStream filename: aFilename aBinaryStream text. ^aFilename writeStream text! defaultOutputStream "^W3Hypertext new" ^HyperComposite new! ! StreamFilter subclass: #ImageFilter instanceVariableNames: 'imageReader tmpFile ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! ImageFilter comment: ' Instance Variables: imageReader tmpFile '! !ImageFilter methodsFor: 'accessing'! image ^imageReader image! inputStream: aBinaryStream! needTmpFile ^true! outputStream ^nil! tmpFilename: aFilename tmpFile := aFilename! ! !ImageFilter methodsFor: 'testing'! isBinary ^true! spawnable ^true! ! PlainTextFilter subclass: #CodeFilter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! CodeFilter comment: 'I can file in the current smalltalk code in the inputStream.'! !CodeFilter methodsFor: 'accessing'! inputStream: aBinaryStream | returnValue | super inputStream: aBinaryStream. returnValue := Dialog confirm: 'The incoming file is smalltalk codes. You can\choose to file that into your image directly.\However, you are advised to save your image\first. Do you want to file in the incoming code now?' withCRs initialAnswer: false. "aBinaryStream text." returnValue ifTrue: [aBinaryStream text. aBinaryStream fileIn]! ! StreamFilter subclass: #DummyFilter instanceVariableNames: 'inStream outStream ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! !DummyFilter methodsFor: 'accessing'! inputStream: aBinaryStream inStream := aBinaryStream. outStream := aBinaryStream! needTmpFile ^false! outputStream ^outStream! outputStream: aStream outStream := aStream. outStream nextPutAll: inStream! ! Object subclass: #ActionMap instanceVariableNames: 'actionEntries ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! ActionMap comment: 'I am used by StreamManager to store some mapping information. Instance Variables: actionEntries of ActionEntry. '! !ActionMap methodsFor: 'accessing'! at: aSymbol put: anActionEntry actionEntries at: aSymbol put: anActionEntry! filterFor: aTypeSymbol subtype: aSubtypeSymbol | actionEntry filter | actionEntry := actionEntries at: aTypeSymbol ifAbsent: nil. actionEntry isNil ifTrue: [filter := nil] ifFalse: [filter := actionEntry subtypeActionMap filterFor: aSubtypeSymbol subtype: nil. filter isNil ifTrue: [filter := actionEntry filter]]. ^filter! viewerFor: aTypeSymbol subtype: aSubtypeSymbol | actionEntry viewer | actionEntry := actionEntries at: aTypeSymbol ifAbsent: nil. actionEntry isNil ifTrue: [viewer := nil] ifFalse: [viewer := actionEntry subtypeActionMap viewerFor: aSubtypeSymbol subtype: nil. viewer isNil ifTrue: [viewer := actionEntry viewer]]. ^viewer! ! !ActionMap methodsFor: 'initialize-release'! initialize actionEntries := Dictionary new.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActionMap class instanceVariableNames: ''! !ActionMap class methodsFor: 'instance creation'! new ^super new initialize! ! ActionMap subclass: #EmptyActionMap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! !EmptyActionMap methodsFor: 'accessing'! filterFor: aTypeSymbol subtype: aSubtypeSymbol ^nil! viewerFor: aTypeSymbol subtype: aSubtypeSymbol ^nil! ! Model subclass: #StreamManager instanceVariableNames: 'outputStream model link tmpFilename spawnFlag cache ' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! StreamManager comment: 'Given an input stream, I either find a parser for it, or I will spawn another process to handle it. The output stream is nil if I don''t find a parser, otherwise it is a stream of hypertext components resulting from parsing the input stream. Currently, for WWWBrowser, I use the responseHeader information to help me make a decision. For example, if it is of MIME type text/html, then I will use a hypertextParser to parse the inputStream. I also need to tell the W3Model what kind of responseHeader I just parsed. Instance Variables: outputStream model saveInTmpFile True means remove the responseHeader from the inputStream and then save the rest of them in a tmpFile. Otherwise, the filtered stream is parsed to the outputStream. Class Variables: FiltersMap (#type, actions) '! !StreamManager methodsFor: 'private'! getFilterFor: aTypeSymbol ^self class filterFor: aTypeSymbol and: nil! getViewerFor: aTypeSymbol ^self class viewerFor: aTypeSymbol and: nil! process: aBinaryStream by: aStreamFilter | tStream fileWriteStream | fileWriteStream := aStreamFilter configure: aBinaryStream filename: tmpFilename. tStream := PositionableTStream on: aBinaryStream to: fileWriteStream. aStreamFilter needTmpFile ifFalse: [aStreamFilter inputStream: tStream. outputStream := aStreamFilter]! processAndSave: aBinaryStream by: aStreamFilter |tStream fileWriteStream| fileWriteStream := aStreamFilter configure: aBinaryStream filename: tmpFilename. tStream := PositionableTStream on: aBinaryStream to: fileWriteStream. tStream setToEnd. tStream close.! processbackup: aBinaryStream by: aStreamFilter aStreamFilter save: aBinaryStream into: tmpFilename. aBinaryStream close. aStreamFilter needTmpFile ifFalse: [[aStreamFilter inputStream: tmpFilename readStream] fork. outputStream := aStreamFilter outputStream].! view: aBinaryStream by: aViewer aViewer save: aBinaryStream into: tmpFilename. aViewer viewFile: tmpFilename. outputStream := nil! ! !StreamManager methodsFor: 'accessing'! inputStream: aBinaryStream "Assign either a Filter or Viewer to process aBinaryStream." ^self subclassResponsibility! link ^link! link: aHyperLink link := aHyperLink! model ^model! model: aW3Model model := aW3Model! outputStream ^outputStream! spawn ^spawnFlag! spawn: aBoolean spawnFlag := aBoolean! tmpFilename ^tmpFilename! tmpFilename: aFilename tmpFilename := aFilename! ! !StreamManager methodsFor: 'initialize-release'! initialize spawnFlag := false.! putNilOutStream outputStream := nil. ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StreamManager class instanceVariableNames: 'TypeMap '! !StreamManager class methodsFor: 'class initialization'! initialize "self initialize"! ! !StreamManager class methodsFor: 'accessing'! filterFor: typeSymbol and: subtypeSymbol | filter | filter := TypeMap filterFor: typeSymbol subtype: subtypeSymbol. filter isNil ifTrue: [^DummyFilter new] ifFalse: [^(Smalltalk at: filter) new]! viewerFor: typeSymbol and: subtypeSymbol | viewer | viewer := TypeMap viewerFor: typeSymbol subtype: subtypeSymbol. viewer isNil ifTrue: [^nil] ifFalse: [^(Smalltalk at: viewer ) new]! ! !StreamManager class methodsFor: 'instance creation'! new ^super new initialize! ! !StreamManager class methodsFor: 'private'! actionEntryFor: aCollection "aCollection is in the form of (type, filter, viewer, subtypecollection). subtypecollection has the same format of aCollection." | subCollection subMap | subCollection := aCollection at: 4. subMap := self actionMapFor: subCollection. ^ActionEntry filter: (aCollection at: 2) viewer: (aCollection at: 3) subtypeActionMap: subMap! actionMapFor: aCollection "aCollection is a collection of quadruples (type, filter, viewer, subtypecollection). subtypecollection has the same format of aCollection." | map entry | map := ActionMap new. aCollection do: [:each | entry := self actionEntryFor: each. map at: (each at: 1) put: entry]. ^map! fillMap "Fill the content of TypeMap." |c| c :=#( #( #text #PlainTextFilter nil #( #(#html #HtmlParser nil #()) #(#mchung #CodeFilter nil #()) ) ) #( #image #BinaryFilter #ImageViewer #()) ). ^self actionMapFor: c! ! StreamFilter subclass: #BinaryFilter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HyperTalk-Framework'! BinaryFilter comment: 'I am an abstract class which configures a stream and filename writeStream to binary. '! !BinaryFilter methodsFor: 'private'! configure: aBinaryStream filename: aFilename aBinaryStream binary. ^aFilename writeStream binary! ! !BinaryFilter methodsFor: 'testing'! needTmpFile ^true! ! StreamManager initialize! HyperApp initialize! Object subclass: #HtmlScannerState instanceVariableNames: 'scanner ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! HtmlScannerState comment: 'HTMLScannerState is an abstract class for all the states in an HTMLScanner. All subclass must implement handle. Together, all the states consititue a state machine. Instance Variables: scanner The scanner which operates on this state.'! !HtmlScannerState methodsFor: 'public access'! handle "Activates self" ^self subclassResponsibility! scanner: aHTMLScanner scanner := aHTMLScanner! ! !HtmlScannerState methodsFor: 'private'! changeState: aHTMLScannerStateClass scanner changeState: (aHTMLScannerStateClass newWithScanner: scanner)! getAnyChar scanner hereChar: scanner nextChar. scanner hereChar isNil ifTrue: [^scanner hereChar: Character space]. ^scanner hereChar! getNextUsefulChar "Set HereChar from inputStream which is not linefeed or carriage return or space, if the previous character is a space." | aChar | aChar := scanner nextChar. [aChar = Character lf or: [aChar = Character cr or: [scanner hereChar = Character space and: [aChar = Character space]]]] whileTrue: [aChar := scanner nextChar]. aChar = nil ifTrue: [^scanner processEndOfInput]. scanner hereChar: aChar! getNonBlankChar "Set HereChar from inputStream which is not linefeed or carriage return or space, if the previous character is a space." | aChar | aChar := scanner nextChar. [aChar = Character lf or: [aChar = Character cr or: [aChar = Character space]]] whileTrue: [aChar := scanner nextChar]. aChar = nil ifTrue: [^scanner processEndOfInput]. scanner hereChar: aChar! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HtmlScannerState class instanceVariableNames: ''! !HtmlScannerState class methodsFor: 'instance creation'! new self error: 'Use the method "newWithScanner" instead of new.'! newWithScanner: aHTMLScanner ^super new scanner: aHTMLScanner! ! HtmlScannerState subclass: #StateEntRef instanceVariableNames: 'buffer ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateEntRef methodsFor: 'private'! appendLocalBuffer: aChar ^buffer nextPut: aChar! buffer ^buffer contents asString! ! !StateEntRef methodsFor: 'accessing'! handle "Handles an entity, until aCharacter is not alphanumeric. If a space is encountered before a ';', that means the document is not a correct HTML 1.0 document. Just treat all the char in buffer as text." | aChar | buffer isEmpty ifTrue: [ self appendLocalBuffer: scanner hereChar]. self getAnyChar. scanner hereChar = $; ifTrue: [ self changeState: StateText. aChar := scanner dtd atEntity: self buffer asLowercase asSymbol. aChar isNil ifTrue: [^self]. ^scanner appendBuffer: aChar]. scanner hereChar = Character space ifTrue: [self changeState: StateText. scanner appendBuffer: $&. self buffer do: [:each | scanner appendBuffer: each]. scanner appendBuffer: scanner hereChar]. ^self appendLocalBuffer: scanner hereChar! ! !StateEntRef methodsFor: 'initialize-release'! initBuffer buffer := WriteStream on: (String new: 10)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StateEntRef class instanceVariableNames: ''! !StateEntRef class methodsFor: 'instance creation'! newWithScanner: aHTMLScanner |instance| instance := super newWithScanner: aHTMLScanner. instance initBuffer. ^instance! ! HtmlScannerState subclass: #StateTag instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! StateTag comment: ' In this state, we are recognizing characters in the tag name of an element, ie, just after the opening ''<''. If aCharacter is alphanumeric, simply add it to the accumulation. If aCharacter is ''/'', then it should be the first character after the ''<''. Otherwise, the tag name has ended, so check to see if it is a valid tag. If aCharacter is ''>'', then we have reached the end of the ''<...>'' markup.'! !StateTag methodsFor: 'private'! getNextUsefulChar "Set HereChar from inputStream which is not linefeed or carriage return or space, if the previous character is a space." | aChar | aChar := scanner nextChar. [aChar = Character lf or: [aChar = Character cr or: [scanner hereChar = Character space and: [aChar = Character space]]]] whileTrue: [^scanner hereChar: Character space "scanner nextChar"]. aChar = nil ifTrue: [^scanner processEndOfInput]. scanner hereChar: aChar! selectState: aString | element | element := scanner atElement: aString. element isNil ifTrue: [^self changeState: StateJunkTag]. scanner endOneBlockWithType: #tag value: aString. (element contentIs: #rcdata) ifTrue: [^self changeState: StateRCData]. (element contentIs: #cdata) ifTrue: [^self changeState: StateCData]. ^self changeState: StateText! ! !StateTag methodsFor: 'accessing'! handle "A < was read. Accumulate the first word as the tag." | tag element | self getNextUsefulChar. scanner hereChar isAlphaNumeric ifTrue: [^scanner appendHereCharToBuffer]. scanner hereChar = $> ifTrue: [tag := scanner buffer asUppercase. ^self selectState: tag]. element := scanner atElement: scanner buffer. element isNil ifTrue: [^self changeState: StateJunkTag] ifFalse: [self changeState: StateTagGap. ^scanner endOneBlockWithType: #tag value: scanner buffer asLowercase]! ! HtmlScannerState subclass: #StateEquals instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateEquals methodsFor: 'accessing'! handle "Have seen the '=' after an attribute. Expect a value to start." self getNonBlankChar. scanner hereChar = $> ifTrue: [^self error: 'syntax error in tag attributes']. scanner hereChar = $" ifTrue: [^self changeState: StateDQ ]. scanner hereChar = $' ifTrue: [^self changeState: StateSQ]. scanner appendHereCharToBuffer. ^self changeState: StateAttrValue! ! StateEntRef subclass: #StateRCDataEntRef instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateRCDataEntRef methodsFor: 'accessing'! handle "Handles an entity, until aCharacter is not alphanumeric. If a space is encountered before a ';', that means the document is not a correct HTML 1.0 document. Just treat all the char in buffer as text." | aChar | buffer isEmpty ifTrue: [ self appendLocalBuffer: scanner hereChar]. self getAnyChar. scanner hereChar = $; ifTrue: [ self changeState: StateRCData. aChar := scanner dtd atEntity: self buffer. aChar isNil ifTrue: [^self]. ^scanner appendBuffer: aChar]. scanner hereChar = Character space ifTrue: [self changeState: StateText. scanner appendBuffer: $&. self buffer do: [:each | scanner appendBuffer: each]. scanner appendBuffer: scanner hereChar]. ^self appendLocalBuffer: scanner hereChar! ! HtmlScannerState subclass: #StateAttrValue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateAttrValue methodsFor: 'accessing'! handle "Just read the Attribute field. Now is the attribute value." | hereChar | self getAnyChar. hereChar := scanner hereChar. hereChar = $> ifTrue: [self changeState: StateText. ^scanner endOneBlockWithType: #attributeValue]. hereChar = Character space ifTrue: [self changeState: StateTagGap. ^scanner endOneBlockWithType: #attributeValue]. ^scanner appendHereCharToBuffer! ! HtmlScannerState subclass: #StateComment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateComment methodsFor: 'accessing'! handle | stream position | stream := scanner inputStream. position := stream position. (stream skipToAll: '-->') isNil ifTrue: [scanner reset. stream position: position. scanner state: scanner initialState] ifFalse: [scanner skipInput: 3]! ! HtmlScannerState subclass: #StateReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateReference methodsFor: 'accessing'! handle "Have just seen a '&', starts a character reference or entity reference." "self getNextUsefulChar." self getAnyChar. scanner hereChar = $# ifTrue: [^self changeState: StateCharRef]. scanner hereChar isAlphabetic ifFalse: [scanner appendBuffer: $&. scanner appendBuffer: scanner hereChar. ^self changeState: StateText]. ^self changeState: StateEntRef! ! HtmlScannerState subclass: #StateTagGap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateTagGap methodsFor: 'accessing'! handle "Expecting an attribute or '>'" self getNextUsefulChar. scanner hereChar = $> ifTrue: [scanner isTokenFound ifFalse: [^self changeState: StateText]. ^scanner endOneBlock]. self changeState: StateAttr. ^scanner appendHereCharToBuffer! ! HtmlScannerState subclass: #StateAfterSmallerThan instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! StateAfterSmallerThan comment: 'The character ''<'' has just read. '! !StateAfterSmallerThan methodsFor: 'private'! checkForComment self getNextUsefulChar. scanner hereChar = $- ifTrue:[ ^self changeState: StateComment]. scanner reset. ^scanner backToPrevState! ! !StateAfterSmallerThan methodsFor: 'accessing'! handle self getNextUsefulChar. scanner hereChar = $!! ifTrue: [^self checkForComment]. scanner hereChar = $/ ifTrue: [^self changeState: StateEndTag ]. scanner skipInput: -1. ^self changeState: StateTag! ! HtmlScannerState subclass: #StateDQ instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateDQ methodsFor: 'accessing'! handle "Accumulating a double-quoted value string." self getNextUsefulChar. scanner hereChar = $" ifTrue: [self changeState: StateTagGap. ^scanner endOneBlockWithType: #attributeValue value: scanner buffer]. ^scanner appendHereCharToBuffer! ! HtmlScannerState subclass: #StateJunkTag instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateJunkTag methodsFor: 'accessing'! handle "Forget the tag just read." " tag := ''. inputStream := scanner inputStream. oPosition := inputStream position. inputStream throughAll: tag. inputStream atEnd ifTrue: [ inputStream position: oPosition]." scanner reset. self changeState: StateText! ! HtmlScannerState subclass: #StateText instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateText methodsFor: 'accessing'! handle "The initial state. In this state we are recognizing text, not markup. Special characters '&' and '<' may be the start of some SGML markup. Otherwise, just send all characters through to the target." self getNextUsefulChar. scanner hereChar = $& ifTrue: [self changeState: StateReference. ^scanner endOneBlockWithType: #pcdata]. scanner hereChar = $< ifTrue: [self changeState: StateAfterSmallerThan. scanner isBufferEmpty ifTrue: [^self]. scanner isBufferAllSpace ifTrue: [^scanner reset]. ^scanner endOneBlockWithType: #text]. ^scanner appendHereCharToBuffer! ! !StateText methodsFor: 'private'! getNextUsefulChar "Set HereChar from inputStream which is not linefeed or carriage return or space, if the previous character is a space." | aChar | aChar := scanner nextChar. [aChar = Character lf or: [aChar = Character cr or: [scanner hereChar = Character space and: [aChar = Character space]]]] whileTrue: [^scanner hereChar: Character space "scanner nextChar"]. aChar = nil ifTrue: [^scanner processEndOfInput]. scanner hereChar: aChar! ! HtmlScannerState subclass: #StateAttr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateAttr methodsFor: 'accessing'! handle "Accumulating an attribute, until '=' or '>' ." self getNonBlankChar. scanner hereChar = $> ifTrue: [self changeState: StateText. ^scanner endOneBlockWithType: #attribute value: scanner buffer asLowercase]. scanner hereChar = $= ifTrue: [scanner endOneBlockWithType: #attribute value: scanner buffer asLowercase. ^self changeState: StateEquals]. ^scanner appendHereCharToBuffer! ! HtmlScannerState subclass: #StateCData instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateCData methodsFor: 'accessing'! handle "The current context is cdata (character data)." self getNextUsefulChar. scanner hereChar = $< ifTrue: [^self doAfterSmallerThan]. ^scanner appendHereCharToBuffer! ! !StateCData methodsFor: 'private'! checkForEnd "' ifTrue: [| element | element := scanner atElement: scanner buffer. element isNil ifTrue: [^self changeState: StateJunkTag]. self changeState: StateText. ^scanner endOneBlockWithType: #endTag value: scanner buffer]. self changeState: StateTagGap. ^scanner endOneBlock! ! HtmlScannerState subclass: #StateStart instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Scanner States'! !StateStart methodsFor: 'accessing'! handle "The initial state. The first few characters are read and check if the source document contains the status line from the server. If it is, then the next state is StateStatusLine. Otherwise, StateText is used. Currently, if the first 5 characters are 'HTTP/', then it is assumed to be a status line." | buffer | self getNextUsefulChar. buffer := scanner buffer. buffer size = 5 ifTrue: [buffer asUppercase = 'HTTP/' ifTrue: [self changeState: StateStatusLine] ifFalse: [scanner resetInputStream. scanner reset. ^self changeState: StateText]]. scanner appendHereCharToBuffer! ! Object subclass: #HtmlDtd instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Parsing'! HtmlDtd comment: 'HTMLDTD defines the grammer and object mapping for HTML. If another SGML document type is needed, e.g. HTML+, then the method initElements & initEntities needs to be overwritten. Actually, adding SGMLDTD as an abstract class may be a better idea. I may create it where there is a need. Note: the keys to the dictionaries Elements and Entities are stored in symbols with lowercase chars. Class InstanceVariableNames: Elements defines the grammer and object mapping. Entities defines the entities in HTML. instance '! !HtmlDtd methodsFor: 'accessing'! atElement: aTagSymbol "Returns nil or an SGMLElement with name = aString." ^self atElement: aTagSymbol ifAbsent: nil! atElement: aTagSymbol ifAbsent: anObject "Returns anObject or an SGMLElement with name = aTagSymbol." ^(self elements) at: aTagSymbol ifAbsent: anObject! atEntity: aTagSymbol "Returns nil or an entity for aString." ^self atEntity: aTagSymbol ifAbsent: nil! atEntity: aTagSymbol ifAbsent: anObject "Returns nil or an entity for aTagSymbol." ^(self entities) at: aTagSymbol ifAbsent: anObject! contentFor: aTagSymbol | element | element := self atElement: aTagSymbol. element isNil ifTrue: [^nil] ifFalse: [^element content]! defaultMappedObject ^WebComponent new type: #text! elements ^HtmlDtd elements! entities ^HtmlDtd entities! mapObject: aSymbol |elt| elt := self elements at: aSymbol ifAbsent: nil. elt isNil ifFalse: [ ^elt mappedObject ]. ^nil! parentsFor: aTagSymbol ^(self atElement: aTagSymbol) parents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HtmlDtd class instanceVariableNames: 'Elements Entities instance '! !HtmlDtd class methodsFor: 'instance creation'! new instance isNil ifTrue: [ instance := super new ]. ^instance! ! !HtmlDtd class methodsFor: 'class initialization'! initElements "Each entry contains (name, content, attributes, parents, mappedObjectClass hTextFlag). self initElements. 'Name', 'content', 'attributes' are defined by the dtd at http://www11.w3.org/hypertext/WWW/MarkUp/HTML.dtd.html. 'Parents' is the set of possible tags that can be the parent of name. MappedObjectClass is the class created for mapping 'name'. also see http://www.w3.org/hypertext/WWW/MarkUp/html-spec/L2Pindex.html" | t | Elements := Dictionary new. t := #( #(#a #mixed #(#HREF #NAME #REL #REV #TITLE #URN #METHODS) #(#address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#address #mixed #() #(#blockquote #body #form) #WebComposite false) #(#b #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#base #mixed #(#HREF) #(#head) #WebComposite false) #(#blockquote #mixed #() #(#blockquote #body #dd #form #li) #WebComposite false) #(#body #mixed #() #(#html) #WebComposite false) #(#br #empty #() #(a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComponent false) #(#cite #mixed #() #(a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#code #mixed #() #(a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#comment #mixed #() #() #WebComposite false) #(#dd #empty #() #(#dl) #WebComposite false) #(#dfn #mixed #() #() #WebComposite true) #(#dir #mixed #(#COMPACT) #(#blockquote #body #dd #form #li) #WebComposite false) #(#dl #mixed #(#COMPACT) #(#blockquote #body #dd #form #li) #WebComposite false) #(#dlc #mixed #(#COMPACT) #() #WebComposite false) #(#dt #empty #() #(#dl) #WebComposite false) #(#em #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#form #mixed #(#ACTION #METHOD #ENCTYPE) #(#blockquote #body #form) #WebComposite false) #(#head #mixed #() #(#html) #WebComposite false) #(#h1 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#h2 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#h3 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#h4 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#h5 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#h6 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#h7 #mixed #() #(#blockquote #body #form) #WebComposite false) #(#hr #empty #() #(#blockquote #body #form #pre) #WebComponent false) #(#html #mixed #() #() #WebComposite false) #(#i #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#img #empty #(#ALT #SRC #ALIGN #ISMAP) #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #samp #strong #tt #var) #WebComponent true) #(#input #empty #(#ALIGN #CHECKED #MAXLENGTH #NAME #SIZE #TYPE #VALUE #SRC) #(#form) #WebComponent false) #(#isindex #empty #() #(#blockquote #body #dd #form #head #li) #WebComponent false) #(#kbd #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#key #mixed #() #() #WebComposite true) #(#li #empty #(#COMPACT) #(#ul #ol #menu #dir) #WebComposite false) #(#link #empty #(#HREF #REL #REV #URL #TITLE #METHODS) #(#head) #WebComponent false) #(#listing #cdata #() #() #WebComposite false) #(#menu #mixed #(#COMPACT) #(#blockquote #body #dd #form #li) #WebComposite false) #(#meta #mixed #(#HTTP-EQUIV #NAME #CONTENT) #(#head) #WebComposite false) #(#nextid #empty #(#N) #(#head) #WebComponent false) #(#ol #mixed #(#COMPACT) #(#blockquote #body #dd #form #li) #WebComposite false) #(#option #empty #(#SELECTED) #(#select) #WebComponent false) #(#p #empty #() #(#address #blockquote #body #dd #form #li) #WebComponent false) #(#plaintext #cdata #() #() #WebComposite false) #(#pre #rcdata #(#WIDTH) #(#blockquote #body #dd #form #li) #WebComposite false) #(#samp #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#select #mixed #(#MULTIPLE #NAME) #(#form) #WebComposite false) #(#strong #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#textarea #mixed #(#COLS #NAME #ROWS) #() #WebComposite false) #(#title #rcdata #() #(#head) #WebComposite false) #(#tt #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#u #mixed #() #() #WebComposite true) #(#ul #mixed #(#COMPACT) #(#blockquote #body #dd #form #li) #WebComposite false) #(#var #mixed #() #(#a #address #b #cite #code #dd #dt #em #h1 #h2 #h3 #h4 #h5 #h6 #i #kbd #li #p #pre #samp #strong #tt #var) #WebComposite true) #(#xmp #cdata #() #() #WebComposite false)). t do: [:each | self addElement: (HtmlElement name: (each at: 1) attributes: (each at: 3) content: (each at: 2) parents: (each at: 4) mappedClassName: (each at: 5) hTextFlag: (each at: 6))]. t do: [:item | (item at: 4) do: [:each | self elements at: each ]]! initEntities | t | Entities := Dictionary new. t := #(#AElig 198 #Aacute 193 #Acirc 194 #Agrave 192 #Aring 197 #Atilde 195 #Auml 196 #Ccedil 199 #ETH 208 #Eacute 201 #Ecirc 202 #Egrave 200 #Euml 203 #Iacute 205 #Icirc 206 #Igrave 204 #Iuml 207 #Ntilde 209 #Oacute 211 #Ocirc 212 #Ograve 210 #Oslash 216 #Otilde 213 #Ouml 214 #THORN 222 #Uacute 218 #Ucirc 219 #Ugrave 217 #Uuml 220 #Yacute 221 #aacute 225 #acirc 226 #aelig 230 #agrave 224 #amp 38 #aring 229 #atilde 227 #auml 228 #ccedil 231 #eacute 233 #ecirc 234 #egrave 232 #emsp 0 #ensp 0 #eth 240 #euml 235 #gt 62 #iacute 237 #icirc 238 #igrave 236 #iuml 239 #lt 60 #nbsp 0 #ntilde 241 #oacute 243 #ocirc 244 #ograve 242 #oslash 248 #otilde 245 #ouml 246 #quote 39 #szlig 223 #thorn 254 #uacute 250 #ucirc 251 #ugrave 249 #uuml 252 #yacute 253 #yuml 255 ). 1 to: t size by: 2 do: [:i | self addEntity: (t at: i) value: (t at: i + 1) asCharacter]! initialize "HtmlDtd initialize" self initElements. self initEntities! ! !HtmlDtd class methodsFor: 'accessing'! addElement: anElement "Elements at: anElement name asString asUppercase put: anElement" Elements at: anElement name asString asLowercase asSymbol put: anElement! addEntity: aSymbol value: aChar Entities at: aSymbol asString asLowercase asSymbol put: aChar! elements ^Elements! entities ^Entities! ! Object subclass: #Token instanceVariableNames: 'value type ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Parsing'! Token comment: 'Token is passed from a scanner to a parser. Instance Variables: value type '! !Token methodsFor: 'initialize-release'! initialize value := nil. type := nil! ! !Token methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'Token ('. type printOn: aStream. aStream space. value printOn: aStream. aStream nextPut: $)! ! !Token methodsFor: 'accessing'! type ^type! type: aStringOrSymbol type := aStringOrSymbol asSymbol! value ^value! value: anObject value := anObject! value: anObject type: aSymbol value := anObject. type := aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Token class instanceVariableNames: ''! !Token class methodsFor: 'instance creation'! new ^super new initialize! ! Object subclass: #HtmlScanner instanceVariableNames: 'currentState buffer currentToken dtd elementStack endOfInput hereChar inputStream isEndToken prevState ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Parsing'! HtmlScanner comment: 'HTMLScanner interacts with HTMLScannerState to form aHTMLScanner. All the tags that is not defined in dtd will be ignored. Instance Variables: currentState keeps track of the current HTMLScannerState. buffer stores the character that will be sent to the outputStream. dtd defines the grammer. currentToken defines the token that will be sent to the outputStream. endOfInput a flag. hereChar the character that is currently processing. inputStream isEndToken a flag. prevState the previous HTMLScannerState.'! !HtmlScanner methodsFor: 'accessing by states'! appendBuffer: aChar ^buffer nextPut: aChar! appendHereCharToBuffer self appendBuffer: hereChar! atElement: aString ^dtd atElement: aString asLowercase asSymbol ifAbsent: nil! backToPrevState | state | state := currentState. self state: prevState. prevState := state! buffer ^buffer contents asString! changeState: aScannerState prevState := currentState. self state: aScannerState! endOneBlock "A block of characters are scanned. A token is set. The buffer is reset" isEndToken := true. self setToken. self resetBuffer! endOneBlockWithType: aSymbol "Similar to endOneBlock but this time, the type of the token is specified." isEndToken := true. self setTokenWithType: aSymbol. self resetBuffer! endOneBlockWithType: aSymbol value: anObject "Similar to endOneBlock but the type and value of the token is set explicitly" isEndToken := true. aSymbol = #text ifTrue: [self setTokenWithType: aSymbol value: anObject] ifFalse: [self setTokenWithType: aSymbol value: anObject "asUppercase"]. self resetBuffer! hereChar ^hereChar! hereChar: aChar hereChar := aChar! inputStream ^inputStream! nextChar ^inputStream next! processEndOfInput hereChar := Character space. endOfInput := true. ^self endOneBlockWithType: #pcdata! skipInput: anInteger inputStream skip: anInteger! state: aSGMLScannerState currentState := aSGMLScannerState! token ^currentToken! ! !HtmlScanner methodsFor: 'accessing'! defaultDTD ^HtmlDtd new! dtd ^dtd! dtd: aDTD dtd := aDTD! input: aStream "set the input Stream. Reset the states." self state: (self initialState). self reset. inputStream := aStream! nextToken "Returns the next token from the inputStream." self clearToken. currentState handle. [self isTokenFound] whileFalse: [currentState handle]. self isEndOfInput ifTrue: [ ^nil]. ^self token! ! !HtmlScanner methodsFor: 'token accessing'! setToken |type| type := currentToken type. isEndToken := true. (type = #text or: [type = #attributeValue]) ifTrue: [currentToken value: self buffer] ifFalse: [currentToken value: self buffer asUppercase]. self resetBuffer. ^currentToken! setTokenWithType: aSymbol ^currentToken value: self buffer type: aSymbol! setTokenWithType: aSymbol value: aString (aSymbol = #text or: [aSymbol = #attributeValue]) ifTrue: [^currentToken value: self buffer type: aSymbol] ifFalse: [^currentToken value: self buffer asUppercase type: aSymbol]. " aSymbol = #text ifTrue: [^currentToken value: aString type: aSymbol]. ^currentToken value: aString asUppercase type: aSymbol"! ! !HtmlScanner methodsFor: 'testing'! inputStreamAtEnd ^inputStream atEnd! isBufferAllSpace | content | content := buffer contents. content size = 0 ifTrue: [^false]. content do: [:each | each = Character space ifFalse: [^false]]. ^true! isBufferEmpty "Returns true if buffer is empty" ^buffer size = 0! isEndOfInput ^endOfInput! isTokenFound "Returns true if end of stream or a token is found." ^isEndToken! ! !HtmlScanner methodsFor: 'initialize-release'! clearToken currentToken := Token new. isEndToken := false! initialize self state: self initialState. dtd := self defaultDTD. self reset.! initialState "^StateStart newWithScanner: self" ^StateText newWithScanner: self! reset endOfInput := false. self resetBuffer. self clearToken! resetBuffer buffer := WriteStream on: (String new: 100)! resetInputStream inputStream reset.! ! !HtmlScanner methodsFor: 'printing'! printOn: aStream aStream nextPutAll: '(Scanner '. hereChar isNil ifFalse: [ aStream nextPut: hereChar]. aStream nextPutAll: ') '.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HtmlScanner class instanceVariableNames: ''! !HtmlScanner class methodsFor: 'instance-creation'! new ^super new initialize! ! Object subclass: #HtmlElement instanceVariableNames: 'name attributes content parents mappedClassName hTextFlag ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Parsing'! HtmlElement comment: 'SGMLElement is used to define the characteristic of a SGML element defined in DTD. This class also specifies the class to be mapped from parsing this element. Instance Variables: name The name of the element. attributes Collection of attributes names in symbol. content parents mappedClassName '! !HtmlElement methodsFor: 'printing'! printOn: aStream aStream nextPut: $<; nextPutAll: name; nextPut: $>! ! !HtmlElement methodsFor: 'testing'! at: aString ifAbsent: aBlock | key | key := aString. (attributes includes: key) ifFalse: [^self error: 'No such attribute - ' , key]. ^values at: key ifAbsent: aBlock! isParentType: aSymbol parents isEmpty ifTrue: [^true]. ^parents includes: aSymbol! ! !HtmlElement methodsFor: 'accessing'! at: aString ^self at: aString ifAbsent: [nil]! at: aString put: anObject | key | key := aString asString asUppercase. (attributes includes: key) ifTrue: [values at: key put: anObject] ifFalse: [self error: 'No such attribute - ' , key]! attributes ^attributes! attributes: aCollection attributes := aCollection collect: [:each | each asString asUppercase]. "self values: Dictionary new"! content ^content! content: anObject content := anObject! contentIs: aSymbol ^content = aSymbol! hasAttribute: aString ^attributes includes: aString! hasAttributeValue: aString (attributes includes: aString) ifFalse: [^false]. values at: aString ifAbsent: [^false]! hTextFlag ^hTextFlag! hTextFlag: aBoolean hTextFlag := aBoolean! mappedClassName: anObject mappedClassName := anObject! mappedObject |obj | obj := (Smalltalk at: mappedClassName) new. obj hTextFlag: hTextFlag. ^obj! name ^name! name: anObject name := anObject asString asUppercase asSymbol! newCopy | tmp | (tmp := self copy) values: Dictionary new. ^tmp! parents ^parents! parents: aSymbolOrArray parents := aSymbolOrArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HtmlElement class instanceVariableNames: ''! !HtmlElement class methodsFor: 'instance creation'! name: nameSymbol attributes: attrCollection content: contentSymbol parents: aSymbolOrArray mappedClassName: aClassName hTextFlag: aBoolean | instance | (instance := self new) name: nameSymbol; attributes: attrCollection; content: contentSymbol; parents: aSymbolOrArray; mappedClassName: aClassName; hTextFlag: aBoolean. ^instance! ! PlainTextFilter subclass: #HtmlParser instanceVariableNames: 'elementStack scanner currentToken dtd optimizeFlag buffer atEnd ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-HTML Parsing'! HtmlParser comment: 'I accept a stream of characters of HTML document and then asks a HtmlScanner to read it. The scanner returns a stream of Tokens back and then HtmlParser buids the parse tree. It sends the parse tree to outputStream. For each token type, a method with the same name as that type needs to be defined. See the category ''token type actions''. Instance Variables: scanner The scanner that supplies the token. It must respond to the message nextToken. elementStack A stack of elements to store the nodes temporarily . outputStream currentToken dtd The place where the grammar and mapping info is defined. optimizeFlag optimization mode. '! !HtmlParser methodsFor: 'accessing'! defaultDTD ^HtmlDtd new! defaultScanner ^HtmlScanner new! inputStream: aCharStream atEnd := false. inputStream := aCharStream. scanner input: aCharStream! needTmpFile ^false! next self hasOutputNode ifTrue: [ ^buffer removeLast]. [(currentToken := scanner nextToken) isNil] whileFalse: [self perform: currentToken type withArguments: #(). self hasOutputNode ifTrue: [^buffer removeLast]]. self flush. self hasOutputNode ifTrue: [^buffer removeLast]. atEnd := true. ^nil! optimize ^optimizeFlag! optimize: aBoolean optimizeFlag := aBoolean! outputStream ^outputStream! outputStream: aStream outputStream := aStream! parse: aStream "Parse aStream and sends the output to outputStream." scanner input: aStream. [(currentToken := scanner nextToken) isNil] whileFalse: [self perform: currentToken type withArguments: #()]. self flush.! ! !HtmlParser methodsFor: 'token type actions'! attribute |anAttribute| elementStack isEmpty ifTrue: [^self]. anAttribute := (Attribute new ) name: currentToken value asLowercase asSymbol. elementStack lastElement addAttribute: anAttribute! attributeValue elementStack isEmpty ifTrue: [^self]. elementStack lastElement lastAttribute value: currentToken value! endTag | tag | tag := currentToken value asLowercase asSymbol. currentToken value: tag. self optimize ifTrue: [tag = #body ifTrue: [^self]]. elementStack isEmpty ifFalse: [self outputThisTagBlock: tag] ifTrue: ["^self error: 'error in HTMLParser ENDTAG'" "Transcript show: 'parsing error in source document'; cr. self halt."]! pcdata "Output a default Text object or find a parent for it." | mappedObject | mappedObject := self defaultTextObject. mappedObject content: currentToken value. self processText: mappedObject! tag | mappedObject tag emptyElement lastElt | tag := currentToken value asLowercase asSymbol. currentToken value: tag. self optimize ifTrue: [tag = #body ifTrue: [^self]]. (dtd contentFor: tag) = #empty ifTrue: [emptyElement := self searchForElement: tag. emptyElement notNil ifTrue: [currentToken type: #ENDTAG. self endTag. currentToken type: #TAG]]. mappedObject := self mapObject: tag. elementStack isEmpty ifTrue: [^elementStack push: mappedObject] ifFalse: [lastElt := elementStack lastElement. (lastElt isComposite and: [(dtd atElement: tag) isParentType: lastElt type]) ifTrue: [^self addLeafAndPush: mappedObject] ifFalse: [self removeLastElement. ^self addLeafAndPush: mappedObject]]! text "Output a MediaText object or find a parent for it." | mappedObject | mappedObject := self defaultTextObject. mappedObject content: currentToken value. self processText: mappedObject! ! !HtmlParser methodsFor: 'initialize-release'! initialize scanner := self defaultScanner. dtd := self defaultDTD. self initStack. self optimize: true. outputStream := self defaultOutputStream. buffer := OrderedCollection new! initStack elementStack := Stack new! ! !HtmlParser methodsFor: 'private-optimized'! processTextOptimized: aHypertextComponent elementStack isEmpty ifTrue: [| composite | composite := WebComposite new type: #text. elementStack push: composite. self addLeaf: aHypertextComponent] ifFalse: [elementStack lastElement isComposite ifTrue: [^self addLeaf: aHypertextComponent] ifFalse: [self removeLastElement. elementStack lastElement isNil ifTrue: [^self outputNode: aHypertextComponent] ifFalse: [^self addLeaf: aHypertextComponent]]]! ! !HtmlParser methodsFor: 'private'! addLeaf: mappedObject elementStack isEmpty ifFalse: [| last | last := elementStack lastElement. last add: mappedObject]! addLeafAndPush: mappedObject "Add a leaf to the parse tree and put it into the elementStack." self addLeaf: mappedObject. elementStack push: mappedObject! defaultOutputStream ^HyperComposite new type: #html! defaultTextObject ^WebComponent new hTextFlag: true; type: #text.! flush "Output all the elements in the elementStack to outputStream." elementStack isEmpty ifFalse: [self outputNode: elementStack firstElement. self initStack]. outputStream flush.! mapObject: aSymbol "Find the object mapped from aSymbol." |anObject| anObject := dtd mapObject: aSymbol. anObject type: aSymbol. ^anObject! outputNode: aNode outputStream nextPut: aNode. buffer addFirst: aNode! outputThisTagBlock: tag "Beginning from the top of elementStack, search for a node with tag = tag. If that node is at the bottom of the stack, then put that node into outputStream. Otherwise, pop all nodes until that node is popped." | mappedObject root | root := elementStack firstElement. elementStack isEmpty ifFalse: [[(mappedObject := elementStack pop) isNil or: [mappedObject type == tag]] whileFalse. (mappedObject notNil and: [elementStack size = 0]) ifTrue: [self outputNode: mappedObject] ifFalse: [(root notNil and: [elementStack size = 0]) ifTrue: [self outputNode: root]]]! processText: aHypertextComponent elementStack isEmpty ifTrue: [self outputNode: aHypertextComponent] ifFalse: [elementStack lastElement isComposite ifTrue: [self addLeaf: aHypertextComponent] ifFalse: [self removeLastElement. elementStack lastElement isNil ifTrue: [self outputNode: aHypertextComponent] ifFalse: [self addLeaf: aHypertextComponent]]]! removeLastElement "Decide if the last element already in the stack needs to be output. It needs to be output only if it is not composite and it is the only element in the stack." | theElement | elementStack isEmpty ifTrue: [^nil]. theElement := elementStack pop. (elementStack size > 0 or: [theElement isComposite]) ifFalse: [self outputNode: theElement]! searchForElement: aTagSymbol "From the top of the stack, search for the node with tag = aString. " | parentTagCollection parent| elementStack isEmpty ifTrue: [^nil]. parentTagCollection := dtd parentsFor: aTagSymbol. parentTagCollection isNil ifTrue: [^self searchForLastElementIn: elementStack withTag: aTagSymbol] ifFalse: [ parent := self searchForLastElementThatContains: parentTagCollection]. parent notNil ifTrue: [ ^self searchForLastElementIn:( parent content) withTag: aTagSymbol] ifFalse: [^nil]! searchForElementIn: aCollectionOrStack withTag: aSymbol | elements | elements := OrderedCollection new. (aCollectionOrStack isNil or: [aCollectionOrStack isEmpty]) ifTrue: [^nil]. aCollectionOrStack do: [:each | each type notNil ifTrue: [each type == aSymbol ifTrue: [elements add: each]]]. elements isEmpty ifTrue: [^nil]. ^elements! searchForElementThatContains: aCollection "Search elementStack for all the elements with tag in aCollection." | elements | elements := OrderedCollection new. elementStack do: [:each | each type notNil ifTrue: [(aCollection includes: each type) ifTrue: [elements add: each]]]. elements isEmpty ifTrue: [^nil]. ^elements! searchForLastElementIn: aCollectionOrStack withTag: aSymbol |aCollection| aCollection := self searchForElementIn: aCollectionOrStack withTag: aSymbol. aCollection isNil ifTrue: [ ^nil]. ^aCollection last! searchForLastElementThatContains: aCollection "Search elementStack for the last element with tag included in aCollection." | elements | elements := self searchForElementThatContains: aCollection. elements isNil ifFalse: [^elements last]. ^nil! ! !HtmlParser methodsFor: 'testing'! atEnd ^atEnd! hasOutputNode ^buffer isEmpty not! isBinary ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HtmlParser class instanceVariableNames: ''! !HtmlParser class methodsFor: 'instance-creation'! new ^super new initialize! ! HtmlDtd initialize! StreamManager subclass: #SMWeb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! SMWeb comment: 'I am the StreamManager for WebClient.'! !SMWeb methodsFor: 'updating'! broadcastForCache: aResponseHeader | item | item := WebCacheItem new. item link: self link; responseHeader: aResponseHeader; filename: self tmpFilename. self changed: #retrievedLink with: item! update: anAspectSymbol with: aCollection anAspectSymbol == #builtVisualComponent ifTrue: [ self changed: #builtVisualComponent with: aCollection ]! ! !SMWeb methodsFor: 'testing'! isResponseOK: aResponseHeader | c | c := aResponseHeader statusCode asNumber. ^c > 199 or: [c < 400]! ! !SMWeb methodsFor: 'private'! defaultHeader ^ResponseHeaderBuilder new buildFrom: 'HTTP/1.0 200 OK MIME-Version: 1.0 Content-Type: text Content-Length: 1' readStream delimiters: Character cr asString! determineEndOfLine: aBinaryStream "Some server returns responseHeader with crlf as endofline but some uses cr. If there is a lf on the first line, then crlf is the endofline character, otherwise cr is used. Reset the stream after testing." |endOfLine| aBinaryStream skipThrough: Character lf asInteger. (aBinaryStream nextMatchFor: Character cr asInteger) ifTrue: [endOfLine := ByteArray with: (Character lf asInteger) with: (Character cr asInteger)] ifFalse: [endOfLine := ByteArray with: (Character lf asInteger)]. aBinaryStream reset. ^endOfLine! getFilterFor: aTypeSymbol subType: aSubTypeSymbol ^self class filterFor: aTypeSymbol and: aSubTypeSymbol! getFilterFrom: aResponseHeader | type subType | type := aResponseHeader mimeType. subType := aResponseHeader mimeSubType. ^self getFilterFor: type subType: subType! getResponseHeader: aBinaryStream "Test the first few characters of the stream and determine the type of the stream. If headers are present in the stream, then a responseHeader is returned. The position of the stream is moved to the start of the body part." | string headerStream responseHeader | string := String new. string := (aBinaryStream nextAvailable: 5) asString. string = 'HTTP/' ifTrue: [| endOfLine headerDelimiter | endOfLine := self determineEndOfLine: aBinaryStream. headerDelimiter := endOfLine , endOfLine. headerStream := (aBinaryStream throughAll: headerDelimiter) asString readStream. responseHeader := ResponseHeaderBuilder new buildFrom: headerStream delimiters: endOfLine asString] ifFalse: [aBinaryStream reset. responseHeader := self tryMyBest]. ^responseHeader! getViewerFor: aTypeSymbol subType: aSubTypeSymbol ^self class viewerFor: aTypeSymbol and: aSubTypeSymbol! getViewerFrom: aResponseHeader | type subType | type := aResponseHeader mimeType. subType := aResponseHeader mimeSubType. ^self getViewerFor: type subType: subType! retrieveResponseHeaderFor: aHyperApp from: aBinaryStream | header | header := self getResponseHeader: aBinaryStream. model responseHeader: header. ^header! tryMyBest |r| r := cache responseHeaderAtLink: self link. r isNil ifTrue: [ r := self defaultHeader]. ^r! ! !SMWeb methodsFor: 'initialize-release'! initFilter: aResponseHeader "Assign a filter based on the MIME content type contained in aResponseHeader." | filter | filter := self getFilterFrom: aResponseHeader. filter notNil ifTrue: [self tmpFilename: (model randomFile nextWithSuffix: '.' , aResponseHeader mimeSubType). filter tmpFilename: self tmpFilename]. ^filter! initViewer: aResponseHeader | viewer | viewer := self getViewerFrom: aResponseHeader. viewer notNil ifTrue: [self tmpFilename: (model randomFile nextWithSuffix: '.' , aResponseHeader mimeSubType)]. ^viewer! ! !SMWeb methodsFor: 'accessing'! cache ^cache! cache: aCache cache := aCache! inputStream: aBinaryStream | filter header viewer | header := self retrieveResponseHeaderFor: model from: aBinaryStream. (self isResponseOK: header) ifFalse: [^self putNilOutStream]. viewer := self initViewer: header. self spawn & viewer notNil ifTrue: [self view: aBinaryStream by: viewer] ifFalse: [filter := self initFilter: header. self process: aBinaryStream by: filter]. self broadcastForCache: header! saveLinkContent: aHyperLink from: aBinaryStream | filter header | self link: aHyperLink. header := self retrieveResponseHeaderFor: model from: aBinaryStream. (self isResponseOK: header) ifFalse: [^self putNilOutStream]. filter := self initFilter: header. self processAndSave: aBinaryStream by: filter. self broadcastForCache: header! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SMWeb class instanceVariableNames: ''! !SMWeb class methodsFor: 'private'! fillMap "Fill the content of TypeMap." |c| c :=#( #( #text #PlainTextFilter nil #( #(#html #HtmlParser nil #()) #(#mchung #CodeFilter nil #()) ) ) #( #image #BinaryFilter #ImageViewer #()) ). ^self actionMapFor: c! ! !SMWeb class methodsFor: 'class initialization'! initialize TypeMap := self fillMap! ! ControllerWithMenu subclass: #WebController instanceVariableNames: 'command ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! WebController comment: 'I am the controller for a Web browser.'! !WebController methodsFor: 'basic control sequence'! controlActivity | aSensor | (aSensor := self sensor) redButtonPressed & self viewHasCursor ifTrue: [command at: aSensor cursorPoint. command execute]. super controlActivity! controlInitialize super controlInitialize. command := model command. command view: view.! ! Object subclass: #WebCache instanceVariableNames: 'cacheItems maxItems maxVisuals totalVisuals ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! !WebCache methodsFor: 'private'! addCacheItem: aW3CacheItem self isFull ifTrue: [self releaseFirstItem]. cacheItems add: aW3CacheItem! addVisualComponent: aVisualComponent for: item self isImagesFull ifTrue: [ self removeFirstVisualComponent]. item visualComponent: aVisualComponent. totalVisuals := totalVisuals + 1.! at: aHyperLink ^cacheItems detect: [:each | each link = aHyperLink] ifNone: nil! atFile: aFilename ^cacheItems detect: [:each | each filename = aFilename] ifNone: nil! cacheItemFor: aHyperLink "Return the cache Item in cacheItems. If not found, then create one." | item | item := self at: aHyperLink. item isNil ifTrue: [item := WebCacheItem new link: aHyperLink. self addCacheItem: item]. ^item! cacheItemForFile: aFilename "Return the cache Item in cacheItems. If not found, then create one." | item | item := self atFile: aFilename. item isNil ifTrue: [item := WebCacheItem new filename: aFilename. self addCacheItem: item]. ^item! processCacheItem: aW3CacheItem |item| self at: aW3CacheItem link putFilename: aW3CacheItem filename. item := self at: aW3CacheItem link. aW3CacheItem copyTo: item.! ! !WebCache methodsFor: 'updating'! update: anAspectSymbol with: anObject anAspectSymbol == #builtVisualComponent ifTrue: [| vc filename | filename := anObject at: 1. vc := anObject at: 2. self atFilename: filename putVisualComponent: vc]. anAspectSymbol == #retrievedLink ifTrue: [self processCacheItem: anObject]! ! !WebCache methodsFor: 'printing'! printOn: aStream cacheItems printOn: aStream! ! !WebCache methodsFor: 'accessing'! at: aHyperLink putFilename: aFilename | item | item := self cacheItemFor: aHyperLink. item filename = aFilename ifFalse: [ item releaseFilename]. item filename: aFilename! atFilename: aFilename putVisualComponent: aVisualComponent | item | item := self atFile: aFilename. item isNil ifTrue: [item := self cacheItemForFile: aFilename. self addVisualComponent: aVisualComponent for: item] ifFalse: [item visualComponent isNil ifTrue: [totalVisuals := totalVisuals + 1]. item visualComponent: aVisualComponent]! clear cacheItems do: [:each | | file | file := each filename. file notNil ifTrue: [file delete]]. cacheItems removeAllSuchThat:[:each | true]. self initialize! filenameAtLink: aHyperLink | item | item := self at: aHyperLink. item notNil ifTrue: [^item filename]. ^nil! maxItems: anInteger maxItems := anInteger! maxVisuals: anInteger maxVisuals := anInteger! responseHeaderAtLink: aHyperLink | item | item := self at: aHyperLink. item notNil ifTrue: [^item responseHeader]. ^nil! totalItems ^cacheItems size! totalVisuals ^totalVisuals! visualComponentAtFile: aFilename | item | item := self atFile: aFilename. item notNil ifTrue: [^item visualComponent]. ^nil! visualComponentAtLink: aHyperLink | item | item := self at: aHyperLink. item notNil ifTrue: [^item visualComponent]. ^nil! ! !WebCache methodsFor: 'initialize-release'! initialize cacheItems := OrderedCollection new. self maxVisuals: 7. self maxItems: 20. totalVisuals := 0! releaseFirstItem cacheItems size > 0 ifTrue: [self releaseItem: cacheItems removeFirst]! releaseItem: aW3CacheItem Transcript show: aW3CacheItem printString , ' removed from cache'. aW3CacheItem release! removeFirstVisualComponent | item | item := cacheItems detect: [:each | each visualComponent notNil]. item notNil ifTrue: [ Transcript show: item printString , ' visualcomponent removed from cache'. item visualComponent: nil. totalVisuals := totalVisuals - 1]! ! !WebCache methodsFor: 'testing'! isFull ^self totalItems >= maxItems! isImagesFull ^self totalVisuals >= maxVisuals! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WebCache class instanceVariableNames: ''! !WebCache class methodsFor: 'instance creation'! new ^super new initialize! ! ApplicationModel subclass: #NetFish instanceVariableNames: 'url model hyperView homepage historian ' classVariableNames: 'DefaultTmpDir DefaultURL ' poolDictionaries: '' category: 'NetFish-Model'! NetFish comment: 'NetFish inherits from ApplicationModel. Most of its codes are generated by the Canvas Tool of VisualWorks. NetFish delegates all of its hypertext and Web related tasks to WebClient, which is a subclass of HyperApp. NetFish also uses LinkHistorian to handle caching. The relationship between the LinkHistorian and NetFish matches the Memento pattern [ralph''s book] in which NetFish is the originator, LinkHistorian is the caretaker, and UrlLink is the memento. Instance Variables: url model hyperView homepage historian '! !NetFish methodsFor: 'actions'! copy self url dependents first controller copy.! cut self url dependents first controller cut.! exit self closeRequest. model release.! fileIn (model cacheStreamFor: model currentLink) fileIn! jumpToNextLink |link| link := historian next. link notNil ifTrue: [self updateLink: link]! jumpToPrevLink | link | link := historian prev. link notNil ifTrue: [self updateLink: link]! openUrl! paste self url dependents first controller paste.! setPreference ^Dialog warn: 'Sorry. Not ready yet. '! ! !NetFish methodsFor: 'accessing'! defaultView ^HyperView new! homepage: aString homepage := aString! hypertextView hyperView isNil ifTrue: [ hyperView := self defaultView]. ^hyperView! tmpDirName: aString model tmpDirName: aString! ! !NetFish methodsFor: 'aspects'! url "This method was generated by UIDefiner. Any edits made here may be lost whenever methods are automatically defined. The initialization provided below may have been preempted by an initialize method." ^url isNil ifTrue: [url := String new asValue] ifFalse: [url]! ! !NetFish methodsFor: 'private'! changedUrl | link | link := UrlLink urlString: self url value. [model jumpTo: link] fork.! defaultTmpDir ^'/tmp/'.! defaultUrl ^self class defaultURL! updateLink: aHypertextLink | currentUrl newUrl | currentUrl := self url value. newUrl := aHypertextLink printString. currentUrl = newUrl ifFalse: [self url value: newUrl. model jumpTo: aHypertextLink].! updateUrl: aHypertextLink | currentUrl newUrl | currentUrl := self url value. newUrl := aHypertextLink printString. currentUrl = newUrl ifFalse: [self url value: newUrl.].! ! !NetFish methodsFor: 'updating'! update: aspectSymbol with: anObject aspectSymbol == #currentLink ifTrue: [ self updateUrl: anObject].! ! !NetFish methodsFor: 'initialize-release'! initialize super initialize. historian := LinkHistorian aspect: #currentLink. model := WebClient new. model addDependent: self. model addDependent: historian. model tmpDirName: self defaultTmpDir. "(TestModel resolver: TextResolver new) registerTo: model. (TestModel resolver: CharResolver new) registerTo: model." self hypertextView model: model. model renderer view: self hypertextView! ! !NetFish methodsFor: 'interface opening'! postBuildWith: aBuilder aBuilder window damageRepairPolicy: (DoubleBufferingWindowDisplayPolicy new). homepage isNil ifTrue: [homepage := self defaultUrl]. self url value: homepage. self changedUrl! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NetFish class instanceVariableNames: ''! !NetFish class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'NetFish' #min: #(#Point 589 395 ) #max: #(#Point 1024 875 ) #bounds: #(#Rectangle 409 299 1039 885 ) #flags: 4 #menu: #fileMenu ) #component: #(#SpecCollection #collection: #( #(#InputFieldSpec #layout: #(#Rectangle 92 16 592 40 ) #model: #url #callbacksSpec: #(#UIEventCallbackSubSpec #valueChangeSelector: #changedUrl ) #tabable: false #menu: #fileMenu #style: #systemDefault ) #(#LabelSpec #layout: #(#Point 20 16 ) #label: 'Location' ) #(#ArbitraryComponentSpec #layout: #(#LayoutFrame 0 0.026534 80 0 0 0.976783 0 0.972752 ) #flags: 9 #component: #hypertextView ) #(#ActionButtonSpec #layout: #(#Rectangle 88 40 172 80 ) #model: #jumpToNextLink #label: 'Forward' #defaultable: true ) #(#ActionButtonSpec #layout: #(#Rectangle 12 40 96 80 ) #model: #jumpToPrevLink #label: 'BackWard' #defaultable: true ) #(#ActionButtonSpec #layout: #(#Rectangle 164 40 248 80 ) #model: #fileIn #label: 'FileIn' #defaultable: true ) ) ) )! ! !NetFish class methodsFor: 'resources'! fileMenu "UIMenuEditor new openOnClass: self andSelector: #fileMenu" ^#(#Menu #( #(#MenuItem #label: 'File' #submenu: #(#Menu #( #(#MenuItem #label: 'Exit' #accessCharacterPosition: 2 ) ) #(1 ) #(#exit ) ) ) #(#MenuItem #label: 'Edit' #submenu: #(#Menu #( #(#MenuItem #label: 'cut' ) #(#MenuItem #label: 'copy' ) #(#MenuItem #label: 'paste' ) ) #(3 ) #(#cut #copy #paste ) ) ) #(#MenuItem #label: 'Navigate' #submenu: #(#Menu #( #(#MenuItem #label: 'Forward' ) #(#MenuItem #label: 'Backward' ) ) #(2 ) #(#jumpToNextLink #jumpToPrevLink ) ) ) #(#MenuItem #label: 'Options' #submenu: #(#Menu #( #(#MenuItem #label: 'Preference' ) ) #(1 ) #(#setPreference ) ) ) ) #(4 ) #(nil nil nil nil ) ) decodeAsLiteralArray! ! !NetFish class methodsFor: 'examples'! example1 "You need to modify the tmp directory. Temporary files will be written in the temp directory you supply. These files are deleted when you exit Netfish through the File|exit menu. You may also want to use another homepage of your preference." "Other url you may want to try are file://.../somelocalfilename http://st-www.cs.uiuc.edu/users/mchung/mcheung05.gif http://st-www.cs.uiuc.edu/users/mchung/test.mchung" "NetFish example1" NetFish defaultURL: 'http://st-www.cs.uiuc.edu/users/chai/research/netfish/'; defaultTmpDir: '/tmp/'. NetFish openOn: (NetFish new)! ! !NetFish class methodsFor: 'class initialization'! initialize " NetFish initialize " self defaultURL:'http://st-www.cs.uiuc.edu'. self defaultTmpDir: '/tmp/'! ! !NetFish class methodsFor: 'accessing'! defaultTmpDir ^DefaultTmpDir! defaultTmpDir: aString DefaultTmpDir := aString! defaultURL ^DefaultURL! defaultURL: aURL DefaultURL := aURL! ! Object subclass: #WebCacheItem instanceVariableNames: 'link filename visualComponent responseHeader ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! !WebCacheItem methodsFor: 'accessing'! filename ^filename! filename: aFilename filename := aFilename! link ^link! link: aHyperLink link := aHyperLink! responseHeader ^responseHeader! responseHeader: aResponseHeader responseHeader := aResponseHeader! visualComponent ^visualComponent! visualComponent: aVisualComponent visualComponent := aVisualComponent! ! !WebCacheItem methodsFor: 'initialize-release'! release self releaseFilename! releaseFilename filename notNil ifTrue: [filename delete]! ! !WebCacheItem methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self class printString, ' '. link printOn: aStream! ! !WebCacheItem methodsFor: 'copying'! copyTo: aW3CacheItem aW3CacheItem link: self link. aW3CacheItem filename: self filename. aW3CacheItem visualComponent: self visualComponent. aW3CacheItem responseHeader: self responseHeader.! ! HyperApp subclass: #WebClient instanceVariableNames: 'optimizeFlag command streamMgr randomFileGenerator cache responseHeader ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! WebClient comment: 'I am a model for a web browser. Instance Variables: process The process that possibly is executing in the background. optimizeFlag mode of optimization. command The current command that will be used by the controller. tmpDir '! !WebClient methodsFor: 'initialize-release'! addDefaultResolvers self registerLinkResolver: UrlResolver new! initialize cache := WebCache new. super initialize. linkAccessor cache: cache. command := CmdClick new model: self. self optimize: true. streamMgr := self defaultStreamManager. self addDependent: cache! release self clearCache. renderer release. super release! ! !WebClient methodsFor: 'cache accessing'! cache cache isNil ifTrue: [cache := self defaultCache]. ^cache! cacheStreamFor: aLink |file| file := cache filenameAtLink: aLink. file isNil ifTrue: [^String new readStream]. ^file readStream! cacheVisualComponentFor: aLink ^cache visualComponentAtLink: aLink! clearCache self cache clear! defaultCache ^WebCache new! ! !WebClient methodsFor: 'accessing'! command ^command! jumpTo: aHyperLink "Setup all the steps for retrieving and parsing..." | parsedStream | super jumpTo: aHyperLink. streamMgr spawn: true; link: aHyperLink; inputStream: linkAccessor outputStream. parsedStream := streamMgr outputStream. document := parsedStream. parsedStream isNil ifTrue: [self handleEmptyStream] ifFalse: [renderer inputStream: parsedStream. self changed: #currentLink with: aHyperLink. " responseHeader notNil ifTrue: [document attributes: responseHeader attributes]"]! optimize: aBoolean optimizeFlag := aBoolean. renderer optimize: aBoolean! randomFile ^randomFileGenerator! responseHeader ^responseHeader! responseHeader: aResponseHeader responseHeader := aResponseHeader! retrieve: aHypertextLink "Retrieve the destination of the link and saved it in a tmp file. Return the tmpFilename." | cacheFilename | cacheFilename := cache filenameAtLink: aHypertextLink. cacheFilename isNil ifTrue: [linkAccessor get: aHypertextLink. streamMgr saveLinkContent: aHypertextLink from: linkAccessor outputStream. " streamMgr spawn: false; link: aHypertextLink; saveInputStream: linkAccessor outputStream." ^streamMgr tmpFilename] ifFalse: [^cacheFilename]! tmpDirName: aDirString randomFileGenerator := RandomFile dirName: aDirString! url: aString self jumpTo: aString! visualComponentForFile: aFilename ^cache visualComponentAtFile: aFilename! ! !WebClient methodsFor: 'private'! componentsMap ^componentsMap! defaultLinkAccessor ^LinkAccessor new cache: self cache! defaultRenderer | r | r := HyperRenderer model: self styleSheet: (self class) defaultStyleSheet. r addDependent: cache. ^r! defaultStreamManager |s| s := SMWeb new model: self; cache: self cache. s addDependent: self cache. ^s! handleEmptyStream "responseHeader statusCode = '200' ifFalse: [Dialog warn: responseHeader firstLine]"! optimize ^optimizeFlag! windowEvent: t1 from: t2 super windowEvent: t1 from: t2! ! !WebClient methodsFor: 'testing'! isRelevant: aSymbol ^aSymbol == #url! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WebClient class instanceVariableNames: ''! !WebClient class methodsFor: 'instance creation'! new ^super new initialize! ! !WebClient class methodsFor: 'class initialization'! initialize ^super initialize! initStreamActionMap! initStyleMap super initStyleMap. StyleMap at: #h1 emphasis: #veryLarge style: nil. StyleMap at: #h2 emphasis: #large style: nil. StyleMap at: #h3 emphasis: #large style: nil. StyleMap at: #h4 emphasis: #large style: nil. StyleMap at: #a emphasis: (Array with: (#color->ColorValue blue) with: #underline) style: nil. StyleMap at: #li emphasis: (#color->ColorValue darkGreen) style: nil. StyleMap at: #b emphasis: #bold style: nil. StyleMap at: #em emphasis: #italic style: nil. StyleMap at: #i emphasis: #italic style: nil. StyleMap at: #u emphasis: #underline style: nil. StyleMap at: #strong emphasis: #bold style: nil. StyleMap at: #dfn emphasis: #italic style: nil. StyleMap at: #cite emphasis: #italic style: nil. StyleMap at: #address emphasis: (Array with: (#color->ColorValue green) with: #italic) style: nil! ! Model subclass: #TestModel instanceVariableNames: 'resolver ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! TestModel comment: 'This class is just a test model for a being dependent agent for a HyperApp. Modify the initialize method of NetFish and test me.'! !TestModel methodsFor: 'private'! defaultResolver ^CharResolver new! ! !TestModel methodsFor: 'accessing'! registerTo: aHypertextModel aHypertextModel registerSubscriber: self. aHypertextModel registerLinkResolver: resolver! resolver resolver isNil ifTrue: [resolver := self defaultResolver]. ^resolver! resolver: aLinkResolver resolver := aLinkResolver! ! !TestModel methodsFor: 'updating'! update: anAspectSymbol with: aParameter anAspectSymbol == resolver defaultAspectSymbol ifTrue: [DialogView warn: aParameter printString]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestModel class instanceVariableNames: ''! !TestModel class methodsFor: 'instance creation'! resolver: aLinkResolver ^self new resolver: aLinkResolver! ! Model subclass: #LinkHistorian instanceVariableNames: 'historyList currentPos aspect ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! LinkHistorian comment: 'I am an observer that keeps track of the access history list of NetFish. '! !LinkHistorian methodsFor: 'initialize-release'! initialize historyList := OrderedCollection new. currentPos := 0.! ! !LinkHistorian methodsFor: 'private'! updateHistoryList: anObject self current = anObject ifFalse: [self add: anObject]! ! !LinkHistorian methodsFor: 'updating'! update: anAspectSymbol with: anObject anAspectSymbol == aspect ifTrue: [ self updateHistoryList: anObject ]! ! !LinkHistorian methodsFor: 'accessing'! add: anObject [currentPos < historyList size] whileTrue: [historyList removeLast]. historyList add: anObject. currentPos := historyList size! aspect: anAspectSymbol aspect := anAspectSymbol! current historyList isEmpty ifTrue: [^nil]. ^historyList at: currentPos! next historyList size > currentPos ifTrue: [currentPos := currentPos + 1. ^historyList at: currentPos] ifFalse: [^nil]! prev (historyList size > 1 and: [currentPos > 1]) ifTrue: [currentPos := currentPos - 1. ^historyList at: currentPos] ifFalse: [^nil]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LinkHistorian class instanceVariableNames: ''! !LinkHistorian class methodsFor: 'instance creation'! aspect: anAspectSymbol ^self new aspect: anAspectSymbol! new ^super new initialize! ! Object subclass: #WebGUIAction instanceVariableNames: 'point visualComponent actionType ' classVariableNames: '' poolDictionaries: '' category: 'NetFish-Model'! WebGUIAction comment: 'W3UserActionState keeps track of the useful information from a user''s action. Currently, it just keeps track of a click action. instance variables: point The point where the user has clicked. visualComponent The view where the user has clicked on. actionType The type of action that the user does.'! !WebGUIAction methodsFor: 'accessing'! actionType ^actionType! actionType: aSymbol actionType := aSymbol! point ^point! point: aPoint point := aPoint! visualComponent ^visualComponent! visualComponent: aVisualComponent visualComponent := aVisualComponent! ! SMWeb initialize! WebClient initialize! NetFish initialize!